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   bool in_param = (Ekind (gnat_param) == E_In_Parameter);
4778   /* The parameter can be indirectly modified if its address is taken.  */
4779   bool ro_param = in_param && !Address_Taken (gnat_param);
4780   bool by_return = false, by_component_ptr = false, by_ref = false;
4781   tree gnu_param;
4782
4783   /* Copy-return is used only for the first parameter of a valued procedure.
4784      It's a copy mechanism for which a parameter is never allocated.  */
4785   if (mech == By_Copy_Return)
4786     {
4787       gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
4788       mech = By_Copy;
4789       by_return = true;
4790     }
4791
4792   /* If this is either a foreign function or if the underlying type won't
4793      be passed by reference, strip off possible padding type.  */
4794   if (TREE_CODE (gnu_param_type) == RECORD_TYPE
4795       && TYPE_IS_PADDING_P (gnu_param_type))
4796     {
4797       tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
4798
4799       if (mech == By_Reference
4800           || foreign
4801           || (!must_pass_by_ref (unpadded_type)
4802               && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
4803         gnu_param_type = unpadded_type;
4804     }
4805
4806   /* If this is a read-only parameter, make a variant of the type that is
4807      read-only.  ??? However, if this is an unconstrained array, that type
4808      can be very complex, so skip it for now.  Likewise for any other
4809      self-referential type.  */
4810   if (ro_param
4811       && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
4812       && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
4813     gnu_param_type = build_qualified_type (gnu_param_type,
4814                                            (TYPE_QUALS (gnu_param_type)
4815                                             | TYPE_QUAL_CONST));
4816
4817   /* For foreign conventions, pass arrays as pointers to the element type.
4818      First check for unconstrained array and get the underlying array.  */
4819   if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
4820     gnu_param_type
4821       = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
4822
4823   /* VMS descriptors are themselves passed by reference.  */
4824   if (mech == By_Descriptor)
4825     gnu_param_type
4826       = build_pointer_type (build_vms_descriptor (gnu_param_type,
4827                                                   Mechanism (gnat_param),
4828                                                   gnat_subprog));
4829
4830   /* Arrays are passed as pointers to element type for foreign conventions.  */
4831   else if (foreign
4832            && mech != By_Copy
4833            && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
4834     {
4835       /* Strip off any multi-dimensional entries, then strip
4836          off the last array to get the component type.  */
4837       while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
4838              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
4839         gnu_param_type = TREE_TYPE (gnu_param_type);
4840
4841       by_component_ptr = true;
4842       gnu_param_type = TREE_TYPE (gnu_param_type);
4843
4844       if (ro_param)
4845         gnu_param_type = build_qualified_type (gnu_param_type,
4846                                                (TYPE_QUALS (gnu_param_type)
4847                                                 | TYPE_QUAL_CONST));
4848
4849       gnu_param_type = build_pointer_type (gnu_param_type);
4850     }
4851
4852   /* Fat pointers are passed as thin pointers for foreign conventions.  */
4853   else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type))
4854     gnu_param_type
4855       = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
4856
4857   /* If we must pass or were requested to pass by reference, do so.
4858      If we were requested to pass by copy, do so.
4859      Otherwise, for foreign conventions, pass In Out or Out parameters
4860      or aggregates by reference.  For COBOL and Fortran, pass all
4861      integer and FP types that way too.  For Convention Ada, use
4862      the standard Ada default.  */
4863   else if (must_pass_by_ref (gnu_param_type)
4864            || mech == By_Reference
4865            || (mech != By_Copy
4866                && ((foreign
4867                     && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
4868                    || (foreign
4869                        && (Convention (gnat_subprog) == Convention_Fortran
4870                            || Convention (gnat_subprog) == Convention_COBOL)
4871                        && (INTEGRAL_TYPE_P (gnu_param_type)
4872                            || FLOAT_TYPE_P (gnu_param_type)))
4873                    || (!foreign
4874                        && default_pass_by_ref (gnu_param_type)))))
4875     {
4876       gnu_param_type = build_reference_type (gnu_param_type);
4877       by_ref = true;
4878     }
4879
4880   /* Pass In Out or Out parameters using copy-in copy-out mechanism.  */
4881   else if (!in_param)
4882     *cico = true;
4883
4884   if (mech == By_Copy && (by_ref || by_component_ptr))
4885     post_error ("?cannot pass & by copy", gnat_param);
4886
4887   /* If this is an Out parameter that isn't passed by reference and isn't
4888      a pointer or aggregate, we don't make a PARM_DECL for it.  Instead,
4889      it will be a VAR_DECL created when we process the procedure, so just
4890      return its type.  For the special parameter of a valued procedure,
4891      never pass it in.
4892
4893      An exception is made to cover the RM-6.4.1 rule requiring "by copy"
4894      Out parameters with discriminants or implicit initial values to be
4895      handled like In Out parameters.  These type are normally built as
4896      aggregates, hence passed by reference, except for some packed arrays
4897      which end up encoded in special integer types.
4898
4899      The exception we need to make is then for packed arrays of records
4900      with discriminants or implicit initial values.  We have no light/easy
4901      way to check for the latter case, so we merely check for packed arrays
4902      of records.  This may lead to useless copy-in operations, but in very
4903      rare cases only, as these would be exceptions in a set of already
4904      exceptional situations.  */
4905   if (Ekind (gnat_param) == E_Out_Parameter
4906       && !by_ref
4907       && (by_return
4908           || (mech != By_Descriptor
4909               && !POINTER_TYPE_P (gnu_param_type)
4910               && !AGGREGATE_TYPE_P (gnu_param_type)))
4911       && !(Is_Array_Type (Etype (gnat_param))
4912            && Is_Packed (Etype (gnat_param))
4913            && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
4914     return gnu_param_type;
4915
4916   gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
4917                                  ro_param || by_ref || by_component_ptr);
4918   DECL_BY_REF_P (gnu_param) = by_ref;
4919   DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
4920   DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
4921   DECL_POINTS_TO_READONLY_P (gnu_param)
4922     = (ro_param && (by_ref || by_component_ptr));
4923
4924   /* If no Mechanism was specified, indicate what we're using, then
4925      back-annotate it.  */
4926   if (mech == Default)
4927     mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
4928
4929   Set_Mechanism (gnat_param, mech);
4930   return gnu_param;
4931 }
4932
4933 /* Return true if DISCR1 and DISCR2 represent the same discriminant.  */
4934
4935 static bool
4936 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
4937 {
4938   while (Present (Corresponding_Discriminant (discr1)))
4939     discr1 = Corresponding_Discriminant (discr1);
4940
4941   while (Present (Corresponding_Discriminant (discr2)))
4942     discr2 = Corresponding_Discriminant (discr2);
4943
4944   return
4945     Original_Record_Component (discr1) == Original_Record_Component (discr2);
4946 }
4947
4948 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
4949    a non-aliased component in the back-end sense.  */
4950
4951 static bool
4952 array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
4953 {
4954   /* If the type below this is a multi-array type, then
4955      this does not have aliased components.  */
4956   if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
4957       && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
4958     return true;
4959
4960   if (Has_Aliased_Components (gnat_type))
4961     return false;
4962
4963   return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
4964 }
4965 \f
4966 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4967    be elaborated at the point of its definition, but do nothing else.  */
4968
4969 void
4970 elaborate_entity (Entity_Id gnat_entity)
4971 {
4972   switch (Ekind (gnat_entity))
4973     {
4974     case E_Signed_Integer_Subtype:
4975     case E_Modular_Integer_Subtype:
4976     case E_Enumeration_Subtype:
4977     case E_Ordinary_Fixed_Point_Subtype:
4978     case E_Decimal_Fixed_Point_Subtype:
4979     case E_Floating_Point_Subtype:
4980       {
4981         Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
4982         Node_Id gnat_hb = Type_High_Bound (gnat_entity);
4983
4984         /* ??? Tests for avoiding static constraint error expression
4985            is needed until the front stops generating bogus conversions
4986            on bounds of real types. */
4987
4988         if (!Raises_Constraint_Error (gnat_lb))
4989           elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
4990                                 1, 0, Needs_Debug_Info (gnat_entity));
4991         if (!Raises_Constraint_Error (gnat_hb))
4992           elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
4993                                 1, 0, Needs_Debug_Info (gnat_entity));
4994       break;
4995       }
4996
4997     case E_Record_Type:
4998       {
4999         Node_Id full_definition = Declaration_Node (gnat_entity);
5000         Node_Id record_definition = Type_Definition (full_definition);
5001
5002         /* If this is a record extension, go a level further to find the
5003            record definition.  */
5004         if (Nkind (record_definition) == N_Derived_Type_Definition)
5005           record_definition = Record_Extension_Part (record_definition);
5006       }
5007       break;
5008
5009     case E_Record_Subtype:
5010     case E_Private_Subtype:
5011     case E_Limited_Private_Subtype:
5012     case E_Record_Subtype_With_Private:
5013       if (Is_Constrained (gnat_entity)
5014           && Has_Discriminants (Base_Type (gnat_entity))
5015           && Present (Discriminant_Constraint (gnat_entity)))
5016         {
5017           Node_Id gnat_discriminant_expr;
5018           Entity_Id gnat_field;
5019
5020           for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
5021                gnat_discriminant_expr
5022                = First_Elmt (Discriminant_Constraint (gnat_entity));
5023                Present (gnat_field);
5024                gnat_field = Next_Discriminant (gnat_field),
5025                gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5026             /* ??? For now, ignore access discriminants.  */
5027             if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5028               elaborate_expression (Node (gnat_discriminant_expr),
5029                                     gnat_entity,
5030                                     get_entity_name (gnat_field), 1, 0, 0);
5031         }
5032       break;
5033
5034     }
5035 }
5036 \f
5037 /* Mark GNAT_ENTITY as going out of scope at this point.  Recursively mark
5038    any entities on its entity chain similarly.  */
5039
5040 void
5041 mark_out_of_scope (Entity_Id gnat_entity)
5042 {
5043   Entity_Id gnat_sub_entity;
5044   unsigned int kind = Ekind (gnat_entity);
5045
5046   /* If this has an entity list, process all in the list.  */
5047   if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5048       || IN (kind, Private_Kind)
5049       || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5050       || kind == E_Function || kind == E_Generic_Function
5051       || kind == E_Generic_Package || kind == E_Generic_Procedure
5052       || kind == E_Loop || kind == E_Operator || kind == E_Package
5053       || kind == E_Package_Body || kind == E_Procedure
5054       || kind == E_Record_Type || kind == E_Record_Subtype
5055       || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5056     for (gnat_sub_entity = First_Entity (gnat_entity);
5057          Present (gnat_sub_entity);
5058          gnat_sub_entity = Next_Entity (gnat_sub_entity))
5059       if (Scope (gnat_sub_entity) == gnat_entity
5060           && gnat_sub_entity != gnat_entity)
5061         mark_out_of_scope (gnat_sub_entity);
5062
5063   /* Now clear this if it has been defined, but only do so if it isn't
5064      a subprogram or parameter.  We could refine this, but it isn't
5065      worth it.  If this is statically allocated, it is supposed to
5066      hang around out of cope.  */
5067   if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5068       && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5069     {
5070       save_gnu_tree (gnat_entity, NULL_TREE, true);
5071       save_gnu_tree (gnat_entity, error_mark_node, true);
5072     }
5073 }
5074 \f
5075 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE.  If this
5076    is a multi-dimensional array type, do this recursively.  */
5077
5078 static void
5079 copy_alias_set (tree gnu_new_type, tree gnu_old_type)
5080 {
5081   /* Remove any padding from GNU_OLD_TYPE.  It doesn't matter in the case
5082      of a one-dimensional array, since the padding has the same alias set
5083      as the field type, but if it's a multi-dimensional array, we need to
5084      see the inner types.  */
5085   while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5086          && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5087              || TYPE_IS_PADDING_P (gnu_old_type)))
5088     gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5089
5090   /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
5091      array.  In that case, it doesn't have the same shape as GNU_NEW_TYPE,
5092      so we need to go down to what does.  */
5093   if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5094     gnu_old_type
5095       = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5096
5097   if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5098       && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5099       && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5100     copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
5101
5102   TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5103   record_component_aliases (gnu_new_type);
5104 }
5105 \f
5106 /* Return a TREE_LIST describing the substitutions needed to reflect
5107    discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
5108    them to GNU_LIST.  If GNAT_TYPE is not specified, use the base type
5109    of GNAT_SUBTYPE. The substitutions can be in any order.  TREE_PURPOSE
5110    gives the tree for the discriminant and TREE_VALUES is the replacement
5111    value.  They are in the form of operands to substitute_in_expr.
5112    DEFINITION is as in gnat_to_gnu_entity.  */
5113
5114 static tree
5115 substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
5116                    tree gnu_list, bool definition)
5117 {
5118   Entity_Id gnat_discrim;
5119   Node_Id gnat_value;
5120
5121   if (No (gnat_type))
5122     gnat_type = Implementation_Base_Type (gnat_subtype);
5123
5124   if (Has_Discriminants (gnat_type))
5125     for (gnat_discrim = First_Stored_Discriminant (gnat_type),
5126          gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
5127          Present (gnat_discrim);
5128          gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
5129          gnat_value = Next_Elmt (gnat_value))
5130       /* Ignore access discriminants.  */
5131       if (!Is_Access_Type (Etype (Node (gnat_value))))
5132         gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
5133                               elaborate_expression
5134                               (Node (gnat_value), gnat_subtype,
5135                                get_entity_name (gnat_discrim), definition,
5136                                1, 0),
5137                               gnu_list);
5138
5139   return gnu_list;
5140 }
5141 \f
5142 /* Return true if the size represented by GNU_SIZE can be handled by an
5143    allocation.  If STATIC_P is true, consider only what can be done with a
5144    static allocation.  */
5145
5146 static bool
5147 allocatable_size_p (tree gnu_size, bool static_p)
5148 {
5149   HOST_WIDE_INT our_size;
5150
5151   /* If this is not a static allocation, the only case we want to forbid
5152      is an overflowing size.  That will be converted into a raise a
5153      Storage_Error.  */
5154   if (!static_p)
5155     return !(TREE_CODE (gnu_size) == INTEGER_CST
5156              && TREE_OVERFLOW (gnu_size));
5157
5158   /* Otherwise, we need to deal with both variable sizes and constant
5159      sizes that won't fit in a host int.  We use int instead of HOST_WIDE_INT
5160      since assemblers may not like very large sizes.  */
5161   if (!host_integerp (gnu_size, 1))
5162     return false;
5163
5164   our_size = tree_low_cst (gnu_size, 1);
5165   return (int) our_size == our_size;
5166 }
5167 \f
5168 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5169    NAME, ARGS and ERROR_POINT.  */
5170
5171 static void
5172 prepend_one_attribute_to (struct attrib ** attr_list,
5173                           enum attr_type attr_type,
5174                           tree attr_name,
5175                           tree attr_args,
5176                           Node_Id attr_error_point)
5177 {
5178   struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5179
5180   attr->type = attr_type;
5181   attr->name = attr_name;
5182   attr->args = attr_args;
5183   attr->error_point = attr_error_point;
5184
5185   attr->next = *attr_list;
5186   *attr_list = attr;
5187 }
5188
5189 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any.  */
5190
5191 static void
5192 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5193 {
5194   Node_Id gnat_temp;
5195
5196   for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5197        gnat_temp = Next_Rep_Item (gnat_temp))
5198     if (Nkind (gnat_temp) == N_Pragma)
5199       {
5200         tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5201         Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5202         enum attr_type etype;
5203
5204         if (Present (gnat_assoc) && Present (First (gnat_assoc))
5205             && Present (Next (First (gnat_assoc)))
5206             && (Nkind (Expression (Next (First (gnat_assoc))))
5207                 == N_String_Literal))
5208           {
5209             gnu_arg0 = get_identifier (TREE_STRING_POINTER
5210                                        (gnat_to_gnu
5211                                         (Expression (Next
5212                                                      (First (gnat_assoc))))));
5213             if (Present (Next (Next (First (gnat_assoc))))
5214                 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
5215                     == N_String_Literal))
5216               gnu_arg1 = get_identifier (TREE_STRING_POINTER
5217                                          (gnat_to_gnu
5218                                           (Expression
5219                                            (Next (Next
5220                                                   (First (gnat_assoc)))))));
5221           }
5222
5223         switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5224           {
5225           case Pragma_Machine_Attribute:
5226             etype = ATTR_MACHINE_ATTRIBUTE;
5227             break;
5228
5229           case Pragma_Linker_Alias:
5230             etype = ATTR_LINK_ALIAS;
5231             break;
5232
5233           case Pragma_Linker_Section:
5234             etype = ATTR_LINK_SECTION;
5235             break;
5236
5237           case Pragma_Linker_Constructor:
5238             etype = ATTR_LINK_CONSTRUCTOR;
5239             break;
5240
5241           case Pragma_Linker_Destructor:
5242             etype = ATTR_LINK_DESTRUCTOR;
5243             break;
5244
5245           case Pragma_Weak_External:
5246             etype = ATTR_WEAK_EXTERNAL;
5247             break;
5248
5249           default:
5250             continue;
5251           }
5252
5253
5254         /* Prepend to the list now.  Make a list of the argument we might
5255            have, as GCC expects it.  */
5256         prepend_one_attribute_to
5257           (attr_list,
5258            etype, gnu_arg0,
5259            (gnu_arg1 != NULL_TREE)
5260            ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5261            Present (Next (First (gnat_assoc)))
5262            ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5263       }
5264 }
5265 \f
5266 /* Get the unpadded version of a GNAT type.  */
5267
5268 tree
5269 get_unpadded_type (Entity_Id gnat_entity)
5270 {
5271   tree type = gnat_to_gnu_type (gnat_entity);
5272
5273   if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5274     type = TREE_TYPE (TYPE_FIELDS (type));
5275
5276   return type;
5277 }
5278 \f
5279 /* Called when we need to protect a variable object using a save_expr.  */
5280
5281 tree
5282 maybe_variable (tree gnu_operand)
5283 {
5284   if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
5285       || TREE_CODE (gnu_operand) == SAVE_EXPR
5286       || TREE_CODE (gnu_operand) == NULL_EXPR)
5287     return gnu_operand;
5288
5289   if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
5290     {
5291       tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
5292                                 TREE_TYPE (gnu_operand),
5293                                 variable_size (TREE_OPERAND (gnu_operand, 0)));
5294
5295       TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
5296         = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
5297       return gnu_result;
5298     }
5299   else
5300     return variable_size (gnu_operand);
5301 }
5302 \f
5303 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5304    type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5305    return the GCC tree to use for that expression.  GNU_NAME is the
5306    qualification to use if an external name is appropriate and DEFINITION is
5307    nonzero if this is a definition of GNAT_ENTITY.  If NEED_VALUE is nonzero,
5308    we need a result.  Otherwise, we are just elaborating this for
5309    side-effects.  If NEED_DEBUG is nonzero we need the symbol for debugging
5310    purposes even if it isn't needed for code generation.  */
5311
5312 static tree
5313 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
5314                       tree gnu_name, bool definition, bool need_value,
5315                       bool need_debug)
5316 {
5317   tree gnu_expr;
5318
5319   /* If we already elaborated this expression (e.g., it was involved
5320      in the definition of a private type), use the old value.  */
5321   if (present_gnu_tree (gnat_expr))
5322     return get_gnu_tree (gnat_expr);
5323
5324   /* If we don't need a value and this is static or a discriminant, we
5325      don't need to do anything.  */
5326   else if (!need_value
5327            && (Is_OK_Static_Expression (gnat_expr)
5328                || (Nkind (gnat_expr) == N_Identifier
5329                    && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5330     return 0;
5331
5332   /* Otherwise, convert this tree to its GCC equivalent.  */
5333   gnu_expr
5334     = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
5335                               gnu_name, definition, need_debug);
5336
5337   /* Save the expression in case we try to elaborate this entity again.  Since
5338      this is not a DECL, don't check it.  Don't save if it's a discriminant. */
5339   if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5340     save_gnu_tree (gnat_expr, gnu_expr, true);
5341
5342   return need_value ? gnu_expr : error_mark_node;
5343 }
5344
5345 /* Similar, but take a GNU expression.  */
5346
5347 static tree
5348 elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
5349                         tree gnu_expr, tree gnu_name, bool definition,
5350                         bool need_debug)
5351 {
5352   tree gnu_decl = NULL_TREE;
5353   /* Skip any conversions and simple arithmetics to see if the expression
5354      is a read-only variable.
5355      ??? This really should remain read-only, but we have to think about
5356      the typing of the tree here.  */
5357   tree gnu_inner_expr
5358     = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5359   bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5360   bool expr_variable;
5361
5362   /* In most cases, we won't see a naked FIELD_DECL here because a
5363      discriminant reference will have been replaced with a COMPONENT_REF
5364      when the type is being elaborated.  However, there are some cases
5365      involving child types where we will.  So convert it to a COMPONENT_REF
5366      here.  We have to hope it will be at the highest level of the
5367      expression in these cases.  */
5368   if (TREE_CODE (gnu_expr) == FIELD_DECL)
5369     gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5370                        build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5371                        gnu_expr, NULL_TREE);
5372
5373   /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5374      that is read-only, make a variable that is initialized to contain the
5375      bound when the package containing the definition is elaborated.  If
5376      this entity is defined at top level and a bound or discriminant value
5377      isn't a constant or a reference to a discriminant, replace the bound
5378      by the variable; otherwise use a SAVE_EXPR if needed.  Note that we
5379      rely here on the fact that an expression cannot contain both the
5380      discriminant and some other variable.  */
5381
5382   expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5383                    && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5384                         && (TREE_READONLY (gnu_inner_expr)
5385                             || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5386                    && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5387
5388   /* If this is a static expression or contains a discriminant, we don't
5389      need the variable for debugging (and can't elaborate anyway if a
5390      discriminant).  */
5391   if (need_debug
5392       && (Is_OK_Static_Expression (gnat_expr)
5393           || CONTAINS_PLACEHOLDER_P (gnu_expr)))
5394     need_debug = false;
5395
5396   /* Now create the variable if we need it.  */
5397   if (need_debug || (expr_variable && expr_global))
5398     gnu_decl
5399       = create_var_decl (create_concat_name (gnat_entity,
5400                                              IDENTIFIER_POINTER (gnu_name)),
5401                          NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5402                          !need_debug, Is_Public (gnat_entity),
5403                          !definition, false, NULL, gnat_entity);
5404
5405   /* We only need to use this variable if we are in global context since GCC
5406      can do the right thing in the local case.  */
5407   if (expr_global && expr_variable)
5408     return gnu_decl;
5409   else if (!expr_variable)
5410     return gnu_expr;
5411   else
5412     return maybe_variable (gnu_expr);
5413 }
5414 \f
5415 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5416    starting bit position so that it is aligned to ALIGN bits, and leaving at
5417    least ROOM bytes free before the field.  BASE_ALIGN is the alignment the
5418    record is guaranteed to get.  */
5419
5420 tree
5421 make_aligning_type (tree type, unsigned int align, tree size,
5422                     unsigned int base_align, int room)
5423 {
5424   /* We will be crafting a record type with one field at a position set to be
5425      the next multiple of ALIGN past record'address + room bytes.  We use a
5426      record placeholder to express record'address.  */
5427
5428   tree record_type = make_node (RECORD_TYPE);
5429   tree record = build0 (PLACEHOLDER_EXPR, record_type);
5430
5431   tree record_addr_st
5432     = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5433
5434   /* The diagram below summarizes the shape of what we manipulate:
5435
5436                     <--------- pos ---------->
5437                 {  +------------+-------------+-----------------+
5438       record  =>{  |############|     ...     | field (type)    |
5439                 {  +------------+-------------+-----------------+
5440                    |<-- room -->|<- voffset ->|<---- size ----->|
5441                    o            o
5442                    |            |
5443                    record_addr  vblock_addr
5444
5445      Every length is in sizetype bytes there, except "pos" which has to be
5446      set as a bit position in the GCC tree for the record.  */
5447
5448   tree room_st = size_int (room);
5449   tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5450   tree voffset_st, pos, field;
5451
5452   tree name = TYPE_NAME (type);
5453
5454   if (TREE_CODE (name) == TYPE_DECL)
5455     name = DECL_NAME (name);
5456
5457   TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
5458
5459   /* Compute VOFFSET and then POS.  The next byte position multiple of some
5460      alignment after some address is obtained by "and"ing the alignment minus
5461      1 with the two's complement of the address.   */
5462
5463   voffset_st = size_binop (BIT_AND_EXPR,
5464                            size_diffop (size_zero_node, vblock_addr_st),
5465                            ssize_int ((align / BITS_PER_UNIT) - 1));
5466
5467   /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype.  */
5468
5469   pos = size_binop (MULT_EXPR,
5470                     convert (bitsizetype,
5471                              size_binop (PLUS_EXPR, room_st, voffset_st)),
5472                     bitsize_unit_node);
5473
5474   /* Craft the GCC record representation.  We exceptionally do everything
5475      manually here because 1) our generic circuitry is not quite ready to
5476      handle the complex position/size expressions we are setting up, 2) we
5477      have a strong simplifying factor at hand: we know the maximum possible
5478      value of voffset, and 3) we have to set/reset at least the sizes in
5479      accordance with this maximum value anyway, as we need them to convey
5480      what should be "alloc"ated for this type.
5481
5482      Use -1 as the 'addressable' indication for the field to prevent the
5483      creation of a bitfield.  We don't need one, it would have damaging
5484      consequences on the alignment computation, and create_field_decl would
5485      make one without this special argument, for instance because of the
5486      complex position expression.  */
5487
5488   field = create_field_decl (get_identifier ("F"), type, record_type,
5489                              1, size, pos, -1);
5490   TYPE_FIELDS (record_type) = field;
5491
5492   TYPE_ALIGN (record_type) = base_align;
5493   TYPE_USER_ALIGN (record_type) = 1;
5494
5495   TYPE_SIZE (record_type)
5496     = size_binop (PLUS_EXPR,
5497                   size_binop (MULT_EXPR, convert (bitsizetype, size),
5498                               bitsize_unit_node),
5499                   bitsize_int (align + room * BITS_PER_UNIT));
5500   TYPE_SIZE_UNIT (record_type)
5501     = size_binop (PLUS_EXPR, size,
5502                   size_int (room + align / BITS_PER_UNIT));
5503
5504   TYPE_MODE (record_type) = BLKmode;
5505
5506   copy_alias_set (record_type, type);
5507   return record_type;
5508 }
5509 \f
5510 /* Return the result of rounding T up to ALIGN.  */
5511
5512 static inline unsigned HOST_WIDE_INT
5513 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5514 {
5515   t += align - 1;
5516   t /= align;
5517   t *= align;
5518   return t;
5519 }
5520
5521 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5522    as the field type of a packed record if IN_RECORD is true, or as the
5523    component type of a packed array if IN_RECORD is false.  See if we can
5524    rewrite it either as a type that has a non-BLKmode, which we can pack
5525    tighter in the packed record case, or as a smaller type with BLKmode.
5526    If so, return the new type.  If not, return the original type.  */
5527
5528 static tree
5529 make_packable_type (tree type, bool in_record)
5530 {
5531   unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5532   unsigned HOST_WIDE_INT new_size;
5533   tree new_type, old_field, field_list = NULL_TREE;
5534
5535   /* No point in doing anything if the size is zero.  */
5536   if (size == 0)
5537     return type;
5538
5539   new_type = make_node (TREE_CODE (type));
5540
5541   /* Copy the name and flags from the old type to that of the new.
5542      Note that we rely on the pointer equality created here for
5543      TYPE_NAME to look through conversions in various places.  */
5544   TYPE_NAME (new_type) = TYPE_NAME (type);
5545   TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5546   TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5547   if (TREE_CODE (type) == RECORD_TYPE)
5548     TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
5549
5550   /* If we are in a record and have a small size, set the alignment to
5551      try for an integral mode.  Otherwise set it to try for a smaller
5552      type with BLKmode.  */
5553   if (in_record && size <= MAX_FIXED_MODE_SIZE)
5554     {
5555       TYPE_ALIGN (new_type) = ceil_alignment (size);
5556       new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
5557     }
5558   else
5559     {
5560       unsigned HOST_WIDE_INT align;
5561
5562       /* Do not try to shrink the size if the RM size is not constant.  */
5563       if (TYPE_CONTAINS_TEMPLATE_P (type)
5564           || !host_integerp (TYPE_ADA_SIZE (type), 1))
5565         return type;
5566
5567       /* Round the RM size up to a unit boundary to get the minimal size
5568          for a BLKmode record.  Give up if it's already the size.  */
5569       new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
5570       new_size = round_up_to_align (new_size, BITS_PER_UNIT);
5571       if (new_size == size)
5572         return type;
5573
5574       align = new_size & -new_size;
5575       TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
5576     }
5577
5578   TYPE_USER_ALIGN (new_type) = 1;
5579
5580   /* Now copy the fields, keeping the position and size as we don't want
5581      to change the layout by propagating the packedness downwards.  */
5582   for (old_field = TYPE_FIELDS (type); old_field;
5583        old_field = TREE_CHAIN (old_field))
5584     {
5585       tree new_field_type = TREE_TYPE (old_field);
5586       tree new_field, new_size;
5587
5588       if (TYPE_MODE (new_field_type) == BLKmode
5589           && (TREE_CODE (new_field_type) == RECORD_TYPE
5590               || TREE_CODE (new_field_type) == UNION_TYPE
5591               || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5592           && host_integerp (TYPE_SIZE (new_field_type), 1))
5593         new_field_type = make_packable_type (new_field_type, true);
5594
5595       /* However, for the last field in a not already packed record type
5596          that is of an aggregate type, we need to use the RM_Size in the
5597          packable version of the record type, see finish_record_type.  */
5598       if (!TREE_CHAIN (old_field)
5599           && !TYPE_PACKED (type)
5600           && (TREE_CODE (new_field_type) == RECORD_TYPE
5601               || TREE_CODE (new_field_type) == UNION_TYPE
5602               || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5603           && !TYPE_IS_FAT_POINTER_P (new_field_type)
5604           && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
5605           && TYPE_ADA_SIZE (new_field_type))
5606         new_size = TYPE_ADA_SIZE (new_field_type);
5607       else
5608         new_size = DECL_SIZE (old_field);
5609
5610       new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
5611                                      new_type, TYPE_PACKED (type), new_size,
5612                                      bit_position (old_field),
5613                                      !DECL_NONADDRESSABLE_P (old_field));
5614
5615       DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
5616       SET_DECL_ORIGINAL_FIELD
5617         (new_field, (DECL_ORIGINAL_FIELD (old_field)
5618                      ? DECL_ORIGINAL_FIELD (old_field) : old_field));
5619
5620       if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
5621         DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
5622
5623       TREE_CHAIN (new_field) = field_list;
5624       field_list = new_field;
5625     }
5626
5627   finish_record_type (new_type, nreverse (field_list), 2, true);
5628   copy_alias_set (new_type, type);
5629
5630   /* If this is a padding record, we never want to make the size smaller
5631      than what was specified.  For QUAL_UNION_TYPE, also copy the size.  */
5632   if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5633       || TREE_CODE (type) == QUAL_UNION_TYPE)
5634     {
5635       TYPE_SIZE (new_type) = TYPE_SIZE (type);
5636       TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
5637     }
5638   else
5639     {
5640       TYPE_SIZE (new_type) = bitsize_int (new_size);
5641       TYPE_SIZE_UNIT (new_type)
5642         = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
5643     }
5644
5645   if (!TYPE_CONTAINS_TEMPLATE_P (type))
5646     SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
5647
5648   compute_record_mode (new_type);
5649
5650   /* Try harder to get a packable type if necessary, for example
5651      in case the record itself contains a BLKmode field.  */
5652   if (in_record && TYPE_MODE (new_type) == BLKmode)
5653     TYPE_MODE (new_type)
5654       = mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1);
5655
5656   /* If neither the mode nor the size has shrunk, return the old type.  */
5657   if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
5658     return type;
5659
5660   return new_type;
5661 }
5662 \f
5663 /* Ensure that TYPE has SIZE and ALIGN.  Make and return a new padded type
5664    if needed.  We have already verified that SIZE and TYPE are large enough.
5665
5666    GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5667    to issue a warning.
5668
5669    IS_USER_TYPE is true if we must complete the original type.
5670
5671    DEFINITION is true if this type is being defined.
5672
5673    SAME_RM_SIZE is true if the RM_Size of the resulting type is to be set
5674    to SIZE too; otherwise, it's set to the RM_Size of the original type.  */
5675
5676 tree
5677 maybe_pad_type (tree type, tree size, unsigned int align,
5678                 Entity_Id gnat_entity, const char *name_trailer,
5679                 bool is_user_type, bool definition, bool same_rm_size)
5680 {
5681   tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
5682   tree orig_size = TYPE_SIZE (type);
5683   unsigned int orig_align = align;
5684   tree record, field;
5685
5686   /* If TYPE is a padded type, see if it agrees with any size and alignment
5687      we were given.  If so, return the original type.  Otherwise, strip
5688      off the padding, since we will either be returning the inner type
5689      or repadding it.  If no size or alignment is specified, use that of
5690      the original padded type.  */
5691   if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5692     {
5693       if ((!size
5694            || operand_equal_p (round_up (size,
5695                                          MAX (align, TYPE_ALIGN (type))),
5696                                round_up (TYPE_SIZE (type),
5697                                          MAX (align, TYPE_ALIGN (type))),
5698                                0))
5699           && (align == 0 || align == TYPE_ALIGN (type)))
5700         return type;
5701
5702       if (!size)
5703         size = TYPE_SIZE (type);
5704       if (align == 0)
5705         align = TYPE_ALIGN (type);
5706
5707       type = TREE_TYPE (TYPE_FIELDS (type));
5708       orig_size = TYPE_SIZE (type);
5709     }
5710
5711   /* If the size is either not being changed or is being made smaller (which
5712      is not done here (and is only valid for bitfields anyway), show the size
5713      isn't changing.  Likewise, clear the alignment if it isn't being
5714      changed.  Then return if we aren't doing anything.  */
5715   if (size
5716       && (operand_equal_p (size, orig_size, 0)
5717           || (TREE_CODE (orig_size) == INTEGER_CST
5718               && tree_int_cst_lt (size, orig_size))))
5719     size = NULL_TREE;
5720
5721   if (align == TYPE_ALIGN (type))
5722     align = 0;
5723
5724   if (align == 0 && !size)
5725     return type;
5726
5727   /* If requested, complete the original type and give it a name.  */
5728   if (is_user_type)
5729     create_type_decl (get_entity_name (gnat_entity), type,
5730                       NULL, !Comes_From_Source (gnat_entity),
5731                       !(TYPE_NAME (type)
5732                         && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5733                         && DECL_IGNORED_P (TYPE_NAME (type))),
5734                       gnat_entity);
5735
5736   /* We used to modify the record in place in some cases, but that could
5737      generate incorrect debugging information.  So make a new record
5738      type and name.  */
5739   record = make_node (RECORD_TYPE);
5740   TYPE_IS_PADDING_P (record) = 1;
5741
5742   if (Present (gnat_entity))
5743     TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
5744
5745   TYPE_VOLATILE (record)
5746     = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
5747
5748   TYPE_ALIGN (record) = align;
5749   if (orig_align)
5750     TYPE_USER_ALIGN (record) = align;
5751
5752   TYPE_SIZE (record) = size ? size : orig_size;
5753   TYPE_SIZE_UNIT (record)
5754     = convert (sizetype,
5755                size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
5756                            bitsize_unit_node));
5757
5758   /* If we are changing the alignment and the input type is a record with
5759      BLKmode and a small constant size, try to make a form that has an
5760      integral mode.  This might allow the padding record to also have an
5761      integral mode, which will be much more efficient.  There is no point
5762      in doing so if a size is specified unless it is also a small constant
5763      size and it is incorrect to do so if we cannot guarantee that the mode
5764      will be naturally aligned since the field must always be addressable.
5765
5766      ??? This might not always be a win when done for a stand-alone object:
5767      since the nominal and the effective type of the object will now have
5768      different modes, a VIEW_CONVERT_EXPR will be required for converting
5769      between them and it might be hard to overcome afterwards, including
5770      at the RTL level when the stand-alone object is accessed as a whole.  */
5771   if (align != 0
5772       && TREE_CODE (type) == RECORD_TYPE
5773       && TYPE_MODE (type) == BLKmode
5774       && TREE_CODE (orig_size) == INTEGER_CST
5775       && !TREE_CONSTANT_OVERFLOW (orig_size)
5776       && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
5777       && (!size
5778           || (TREE_CODE (size) == INTEGER_CST
5779               && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
5780     {
5781       tree packable_type = make_packable_type (type, true);
5782       if (TYPE_MODE (packable_type) != BLKmode
5783           && align >= TYPE_ALIGN (packable_type))
5784         type = packable_type;
5785     }
5786
5787   /* Now create the field with the original size.  */
5788   field  = create_field_decl (get_identifier ("F"), type, record, 0,
5789                               orig_size, bitsize_zero_node, 1);
5790   DECL_INTERNAL_P (field) = 1;
5791
5792   /* Do not finalize it until after the auxiliary record is built.  */
5793   finish_record_type (record, field, 1, true);
5794
5795   /* Set the same size for its RM_size if requested; otherwise reuse
5796      the RM_size of the original type.  */
5797   SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
5798
5799   /* Unless debugging information isn't being written for the input type,
5800      write a record that shows what we are a subtype of and also make a
5801      variable that indicates our size, if still variable. */
5802   if (TYPE_NAME (record)
5803       && AGGREGATE_TYPE_P (type)
5804       && TREE_CODE (orig_size) != INTEGER_CST
5805       && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5806            && DECL_IGNORED_P (TYPE_NAME (type))))
5807     {
5808       tree marker = make_node (RECORD_TYPE);
5809       tree name = TYPE_NAME (record);
5810       tree orig_name = TYPE_NAME (type);
5811
5812       if (TREE_CODE (name) == TYPE_DECL)
5813         name = DECL_NAME (name);
5814
5815       if (TREE_CODE (orig_name) == TYPE_DECL)
5816         orig_name = DECL_NAME (orig_name);
5817
5818       TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
5819       finish_record_type (marker,
5820                           create_field_decl (orig_name, integer_type_node,
5821                                              marker, 0, NULL_TREE, NULL_TREE,
5822                                              0),
5823                           0, false);
5824
5825       add_parallel_type (TYPE_STUB_DECL (record), marker);
5826
5827       if (size && TREE_CODE (size) != INTEGER_CST && definition)
5828         create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
5829                          bitsizetype, TYPE_SIZE (record), false, false, false,
5830                          false, NULL, gnat_entity);
5831     }
5832
5833   rest_of_record_type_compilation (record);
5834
5835   /* If the size was widened explicitly, maybe give a warning.  Take the
5836      original size as the maximum size of the input if there was an
5837      unconstrained record involved and round it up to the specified alignment,
5838      if one was specified.  */
5839   if (CONTAINS_PLACEHOLDER_P (orig_size))
5840     orig_size = max_size (orig_size, true);
5841
5842   if (align)
5843     orig_size = round_up (orig_size, align);
5844
5845   if (size && Present (gnat_entity)
5846       && !operand_equal_p (size, orig_size, 0)
5847       && !(TREE_CODE (size) == INTEGER_CST
5848            && TREE_CODE (orig_size) == INTEGER_CST
5849            && tree_int_cst_lt (size, orig_size)))
5850     {
5851       Node_Id gnat_error_node = Empty;
5852
5853       if (Is_Packed_Array_Type (gnat_entity))
5854         gnat_entity = Original_Array_Type (gnat_entity);
5855
5856       if ((Ekind (gnat_entity) == E_Component
5857            || Ekind (gnat_entity) == E_Discriminant)
5858           && Present (Component_Clause (gnat_entity)))
5859         gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
5860       else if (Present (Size_Clause (gnat_entity)))
5861         gnat_error_node = Expression (Size_Clause (gnat_entity));
5862
5863       /* Generate message only for entities that come from source, since
5864          if we have an entity created by expansion, the message will be
5865          generated for some other corresponding source entity.  */
5866       if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
5867         post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
5868                             gnat_entity,
5869                             size_diffop (size, orig_size));
5870
5871       else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
5872         post_error_ne_tree ("component of& padded{ by ^ bits}?",
5873                             gnat_entity, gnat_entity,
5874                             size_diffop (size, orig_size));
5875     }
5876
5877   return record;
5878 }
5879 \f
5880 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5881    the value passed against the list of choices.  */
5882
5883 tree
5884 choices_to_gnu (tree operand, Node_Id choices)
5885 {
5886   Node_Id choice;
5887   Node_Id gnat_temp;
5888   tree result = integer_zero_node;
5889   tree this_test, low = 0, high = 0, single = 0;
5890
5891   for (choice = First (choices); Present (choice); choice = Next (choice))
5892     {
5893       switch (Nkind (choice))
5894         {
5895         case N_Range:
5896           low = gnat_to_gnu (Low_Bound (choice));
5897           high = gnat_to_gnu (High_Bound (choice));
5898
5899           /* There's no good type to use here, so we might as well use
5900              integer_type_node.  */
5901           this_test
5902             = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5903                                build_binary_op (GE_EXPR, integer_type_node,
5904                                                 operand, low),
5905                                build_binary_op (LE_EXPR, integer_type_node,
5906                                                 operand, high));
5907
5908           break;
5909
5910         case N_Subtype_Indication:
5911           gnat_temp = Range_Expression (Constraint (choice));
5912           low = gnat_to_gnu (Low_Bound (gnat_temp));
5913           high = gnat_to_gnu (High_Bound (gnat_temp));
5914
5915           this_test
5916             = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5917                                build_binary_op (GE_EXPR, integer_type_node,
5918                                                 operand, low),
5919                                build_binary_op (LE_EXPR, integer_type_node,
5920                                                 operand, high));
5921           break;
5922
5923         case N_Identifier:
5924         case N_Expanded_Name:
5925           /* This represents either a subtype range, an enumeration
5926              literal, or a constant  Ekind says which.  If an enumeration
5927              literal or constant, fall through to the next case.  */
5928           if (Ekind (Entity (choice)) != E_Enumeration_Literal
5929               && Ekind (Entity (choice)) != E_Constant)
5930             {
5931               tree type = gnat_to_gnu_type (Entity (choice));
5932
5933               low = TYPE_MIN_VALUE (type);
5934               high = TYPE_MAX_VALUE (type);
5935
5936               this_test
5937                 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5938                                    build_binary_op (GE_EXPR, integer_type_node,
5939                                                     operand, low),
5940                                    build_binary_op (LE_EXPR, integer_type_node,
5941                                                     operand, high));
5942               break;
5943             }
5944           /* ... fall through ... */
5945         case N_Character_Literal:
5946         case N_Integer_Literal:
5947           single = gnat_to_gnu (choice);
5948           this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
5949                                        single);
5950           break;
5951
5952         case N_Others_Choice:
5953           this_test = integer_one_node;
5954           break;
5955
5956         default:
5957           gcc_unreachable ();
5958         }
5959
5960       result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5961                                 result, this_test);
5962     }
5963
5964   return result;
5965 }
5966 \f
5967 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
5968    type FIELD_TYPE to be placed in RECORD_TYPE.  Return the result.  */
5969
5970 static int
5971 adjust_packed (tree field_type, tree record_type, int packed)
5972 {
5973   /* If the field contains an item of variable size, we cannot pack it
5974      because we cannot create temporaries of non-fixed size in case
5975      we need to take the address of the field.  See addressable_p and
5976      the notes on the addressability issues for further details.  */
5977   if (is_variable_size (field_type))
5978     return 0;
5979
5980   /* If the alignment of the record is specified and the field type
5981      is over-aligned, request Storage_Unit alignment for the field.  */
5982   if (packed == -2)
5983     {
5984       if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
5985         return -1;
5986       else
5987         return 0;
5988     }
5989
5990   return packed;
5991 }
5992
5993 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
5994    placed in GNU_RECORD_TYPE.
5995
5996    PACKED is 1 if the enclosing record is packed, -1 if the enclosing
5997    record has Component_Alignment of Storage_Unit, -2 if the enclosing
5998    record has a specified alignment.
5999
6000    DEFINITION is true if this field is for a record being defined.  */
6001
6002 static tree
6003 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6004                    bool definition)
6005 {
6006   tree gnu_field_id = get_entity_name (gnat_field);
6007   tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6008   tree gnu_field, gnu_size, gnu_pos;
6009   bool needs_strict_alignment
6010     = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6011        || Treat_As_Volatile (gnat_field));
6012
6013   /* If this field requires strict alignment, we cannot pack it because
6014      it would very likely be under-aligned in the record.  */
6015   if (needs_strict_alignment)
6016     packed = 0;
6017   else
6018     packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6019
6020   /* If a size is specified, use it.  Otherwise, if the record type is packed,
6021      use the official RM size.  See "Handling of Type'Size Values" in Einfo
6022      for further details.  */
6023   if (Known_Static_Esize (gnat_field))
6024     gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6025                               gnat_field, FIELD_DECL, false, true);
6026   else if (packed == 1)
6027     gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6028                               gnat_field, FIELD_DECL, false, true);
6029   else
6030     gnu_size = NULL_TREE;
6031
6032   /* If we have a specified size that's smaller than that of the field type,
6033      or a position is specified, and the field type is also a record that's
6034      BLKmode, see if we can get either an integral mode form of the type or
6035      a smaller BLKmode form.  If we can, show a size was specified for the
6036      field if there wasn't one already, so we know to make this a bitfield
6037      and avoid making things wider.
6038
6039      Doing this is first useful if the record is packed because we may then
6040      place the field at a non-byte-aligned position and so achieve tighter
6041      packing.
6042
6043      This is in addition *required* if the field shares a byte with another
6044      field and the front-end lets the back-end handle the references, because
6045      GCC does not handle BLKmode bitfields properly.
6046
6047      We avoid the transformation if it is not required or potentially useful,
6048      as it might entail an increase of the field's alignment and have ripple
6049      effects on the outer record type.  A typical case is a field known to be
6050      byte aligned and not to share a byte with another field.
6051
6052      Besides, we don't even look the possibility of a transformation in cases
6053      known to be in error already, for instance when an invalid size results
6054      from a component clause.  */
6055
6056   if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6057       && TYPE_MODE (gnu_field_type) == BLKmode
6058       && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6059       && (packed == 1
6060           || (gnu_size
6061               && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6062                   || Present (Component_Clause (gnat_field))))))
6063     {
6064       /* See what the alternate type and size would be.  */
6065       tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6066
6067       bool has_byte_aligned_clause
6068         = Present (Component_Clause (gnat_field))
6069           && (UI_To_Int (Component_Bit_Offset (gnat_field))
6070               % BITS_PER_UNIT == 0);
6071
6072       /* Compute whether we should avoid the substitution.  */
6073       bool reject
6074         /* There is no point substituting if there is no change...  */
6075         = (gnu_packable_type == gnu_field_type)
6076          /* ... nor when the field is known to be byte aligned and not to
6077             share a byte with another field.  */
6078           || (has_byte_aligned_clause
6079               && value_factor_p (gnu_size, BITS_PER_UNIT))
6080          /* The size of an aliased field must be an exact multiple of the
6081             type's alignment, which the substitution might increase.  Reject
6082             substitutions that would so invalidate a component clause when the
6083             specified position is byte aligned, as the change would have no
6084             real benefit from the packing standpoint anyway.  */
6085           || (Is_Aliased (gnat_field)
6086               && has_byte_aligned_clause
6087               && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
6088
6089       /* Substitute unless told otherwise.  */
6090       if (!reject)
6091         {
6092           gnu_field_type = gnu_packable_type;
6093
6094           if (!gnu_size)
6095             gnu_size = rm_size (gnu_field_type);
6096         }
6097     }
6098
6099   /* If we are packing the record and the field is BLKmode, round the
6100      size up to a byte boundary.  */
6101   if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6102     gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6103
6104   if (Present (Component_Clause (gnat_field)))
6105     {
6106       gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6107       gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6108                                 gnat_field, FIELD_DECL, false, true);
6109
6110       /* Ensure the position does not overlap with the parent subtype,
6111          if there is one.  */
6112       if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
6113         {
6114           tree gnu_parent
6115             = gnat_to_gnu_type (Parent_Subtype
6116                                 (Underlying_Type (Scope (gnat_field))));
6117
6118           if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6119               && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6120             {
6121               post_error_ne_tree
6122                 ("offset of& must be beyond parent{, minimum allowed is ^}",
6123                  First_Bit (Component_Clause (gnat_field)), gnat_field,
6124                  TYPE_SIZE_UNIT (gnu_parent));
6125             }
6126         }
6127
6128       /* If this field needs strict alignment, ensure the record is
6129          sufficiently aligned and that that position and size are
6130          consistent with the alignment.  */
6131       if (needs_strict_alignment)
6132         {
6133           TYPE_ALIGN (gnu_record_type)
6134             = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6135
6136           if (gnu_size
6137               && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6138             {
6139               if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6140                 post_error_ne_tree
6141                   ("atomic field& must be natural size of type{ (^)}",
6142                    Last_Bit (Component_Clause (gnat_field)), gnat_field,
6143                    TYPE_SIZE (gnu_field_type));
6144
6145               else if (Is_Aliased (gnat_field))
6146                 post_error_ne_tree
6147                   ("size of aliased field& must be ^ bits",
6148                    Last_Bit (Component_Clause (gnat_field)), gnat_field,
6149                    TYPE_SIZE (gnu_field_type));
6150
6151               else if (Strict_Alignment (Etype (gnat_field)))
6152                 post_error_ne_tree
6153                   ("size of & with aliased or tagged components not ^ bits",
6154                    Last_Bit (Component_Clause (gnat_field)), gnat_field,
6155                    TYPE_SIZE (gnu_field_type));
6156
6157               gnu_size = NULL_TREE;
6158             }
6159
6160           if (!integer_zerop (size_binop
6161                               (TRUNC_MOD_EXPR, gnu_pos,
6162                                bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6163             {
6164               if (Is_Aliased (gnat_field))
6165                 post_error_ne_num
6166                   ("position of aliased field& must be multiple of ^ bits",
6167                    First_Bit (Component_Clause (gnat_field)), gnat_field,
6168                    TYPE_ALIGN (gnu_field_type));
6169
6170               else if (Treat_As_Volatile (gnat_field))
6171                 post_error_ne_num
6172                   ("position of volatile field& must be multiple of ^ bits",
6173                    First_Bit (Component_Clause (gnat_field)), gnat_field,
6174                    TYPE_ALIGN (gnu_field_type));
6175
6176               else if (Strict_Alignment (Etype (gnat_field)))
6177                 post_error_ne_num
6178   ("position of & with aliased or tagged components not multiple of ^ bits",
6179                    First_Bit (Component_Clause (gnat_field)), gnat_field,
6180                    TYPE_ALIGN (gnu_field_type));
6181
6182               else
6183                 gcc_unreachable ();
6184
6185               gnu_pos = NULL_TREE;
6186             }
6187         }
6188
6189       if (Is_Atomic (gnat_field))
6190         check_ok_for_atomic (gnu_field_type, gnat_field, false);
6191     }
6192
6193   /* If the record has rep clauses and this is the tag field, make a rep
6194      clause for it as well.  */
6195   else if (Has_Specified_Layout (Scope (gnat_field))
6196            && Chars (gnat_field) == Name_uTag)
6197     {
6198       gnu_pos = bitsize_zero_node;
6199       gnu_size = TYPE_SIZE (gnu_field_type);
6200     }
6201
6202   else
6203     gnu_pos = NULL_TREE;
6204
6205   /* We need to make the size the maximum for the type if it is
6206      self-referential and an unconstrained type.  In that case, we can't
6207      pack the field since we can't make a copy to align it.  */
6208   if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6209       && !gnu_size
6210       && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6211       && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6212     {
6213       gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6214       packed = 0;
6215     }
6216
6217   /* If a size is specified, adjust the field's type to it.  */
6218   if (gnu_size)
6219     {
6220       /* If the field's type is justified modular, we would need to remove
6221          the wrapper to (better) meet the layout requirements.  However we
6222          can do so only if the field is not aliased to preserve the unique
6223          layout and if the prescribed size is not greater than that of the
6224          packed array to preserve the justification.  */
6225       if (!needs_strict_alignment
6226           && TREE_CODE (gnu_field_type) == RECORD_TYPE
6227           && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6228           && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6229                <= 0)
6230         gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6231
6232       gnu_field_type
6233         = make_type_from_size (gnu_field_type, gnu_size,
6234                                Has_Biased_Representation (gnat_field));
6235       gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6236                                        "PAD", false, definition, true);
6237     }
6238
6239   /* Otherwise (or if there was an error), don't specify a position.  */
6240   else
6241     gnu_pos = NULL_TREE;
6242
6243   gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6244               || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6245
6246   /* Now create the decl for the field.  */
6247   gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6248                                  packed, gnu_size, gnu_pos,
6249                                  Is_Aliased (gnat_field));
6250   Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6251   TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6252
6253   if (Ekind (gnat_field) == E_Discriminant)
6254     DECL_DISCRIMINANT_NUMBER (gnu_field)
6255       = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6256
6257   return gnu_field;
6258 }
6259 \f
6260 /* Return true if TYPE is a type with variable size, a padding type with a
6261    field of variable size or is a record that has a field such a field.  */
6262
6263 static bool
6264 is_variable_size (tree type)
6265 {
6266   tree field;
6267
6268   if (!TREE_CONSTANT (TYPE_SIZE (type)))
6269     return true;
6270
6271   if (TREE_CODE (type) == RECORD_TYPE
6272       && TYPE_IS_PADDING_P (type)
6273       && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6274     return true;
6275
6276   if (TREE_CODE (type) != RECORD_TYPE
6277       && TREE_CODE (type) != UNION_TYPE
6278       && TREE_CODE (type) != QUAL_UNION_TYPE)
6279     return false;
6280
6281   for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6282     if (is_variable_size (TREE_TYPE (field)))
6283       return true;
6284
6285   return false;
6286 }
6287 \f
6288 /* qsort comparer for the bit positions of two record components.  */
6289
6290 static int
6291 compare_field_bitpos (const PTR rt1, const PTR rt2)
6292 {
6293   const_tree const field1 = * (const_tree const *) rt1;
6294   const_tree const field2 = * (const_tree const *) rt2;
6295   const int ret
6296     = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6297
6298   return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6299 }
6300
6301 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
6302    of GCC trees for fields that are in the record and have already been
6303    processed.  When called from gnat_to_gnu_entity during the processing of a
6304    record type definition, the GCC nodes for the discriminants will be on
6305    the chain.  The other calls to this function are recursive calls from
6306    itself for the Component_List of a variant and the chain is empty.
6307
6308    PACKED is 1 if this is for a packed record, -1 if this is for a record
6309    with Component_Alignment of Storage_Unit, -2 if this is for a record
6310    with a specified alignment.
6311
6312    DEFINITION is true if we are defining this record.
6313
6314    P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6315    with a rep clause is to be added.  If it is nonzero, that is all that
6316    should be done with such fields.
6317
6318    CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6319    laying out the record.  This means the alignment only serves to force fields
6320    to be bitfields, but not require the record to be that aligned.  This is
6321    used for variants.
6322
6323    ALL_REP, if true, means a rep clause was found for all the fields.  This
6324    simplifies the logic since we know we're not in the mixed case.
6325
6326    DO_NOT_FINALIZE, if true, means that the record type is expected to be
6327    modified afterwards so it will not be sent to the back-end for finalization.
6328
6329    UNCHECKED_UNION, if true, means that we are building a type for a record
6330    with a Pragma Unchecked_Union.
6331
6332    The processing of the component list fills in the chain with all of the
6333    fields of the record and then the record type is finished.  */
6334
6335 static void
6336 components_to_record (tree gnu_record_type, Node_Id component_list,
6337                       tree gnu_field_list, int packed, bool definition,
6338                       tree *p_gnu_rep_list, bool cancel_alignment,
6339                       bool all_rep, bool do_not_finalize, bool unchecked_union)
6340 {
6341   Node_Id component_decl;
6342   Entity_Id gnat_field;
6343   Node_Id variant_part;
6344   tree gnu_our_rep_list = NULL_TREE;
6345   tree gnu_field, gnu_last;
6346   bool layout_with_rep = false;
6347   bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6348
6349   /* For each variable within each component declaration create a GCC field
6350      and add it to the list, skipping any pragmas in the list.  */
6351   if (Present (Component_Items (component_list)))
6352     for (component_decl = First_Non_Pragma (Component_Items (component_list));
6353          Present (component_decl);
6354          component_decl = Next_Non_Pragma (component_decl))
6355       {
6356         gnat_field = Defining_Entity (component_decl);
6357
6358         if (Chars (gnat_field) == Name_uParent)
6359           gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
6360         else
6361           {
6362             gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
6363                                            packed, definition);
6364
6365             /* If this is the _Tag field, put it before any discriminants,
6366                instead of after them as is the case for all other fields.
6367                Ignore field of void type if only annotating.  */
6368             if (Chars (gnat_field) == Name_uTag)
6369               gnu_field_list = chainon (gnu_field_list, gnu_field);
6370             else
6371               {
6372                 TREE_CHAIN (gnu_field) = gnu_field_list;
6373                 gnu_field_list = gnu_field;
6374               }
6375           }
6376
6377           save_gnu_tree (gnat_field, gnu_field, false);
6378       }
6379
6380   /* At the end of the component list there may be a variant part.  */
6381   variant_part = Variant_Part (component_list);
6382
6383   /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6384      mutually exclusive and should go in the same memory.  To do this we need
6385      to treat each variant as a record whose elements are created from the
6386      component list for the variant.  So here we create the records from the
6387      lists for the variants and put them all into the QUAL_UNION_TYPE.
6388      If this is an Unchecked_Union, we make a UNION_TYPE instead or
6389      use GNU_RECORD_TYPE if there are no fields so far.  */
6390   if (Present (variant_part))
6391     {
6392       tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
6393       Node_Id variant;
6394       tree gnu_name = TYPE_NAME (gnu_record_type);
6395       tree gnu_var_name
6396         = concat_id_with_name (get_identifier (Get_Name_String
6397                                                (Chars (Name (variant_part)))),
6398                                "XVN");
6399       tree gnu_union_type;
6400       tree gnu_union_name;
6401       tree gnu_union_field;
6402       tree gnu_variant_list = NULL_TREE;
6403
6404       if (TREE_CODE (gnu_name) == TYPE_DECL)
6405         gnu_name = DECL_NAME (gnu_name);
6406
6407       gnu_union_name = concat_id_with_name (gnu_name,
6408                                             IDENTIFIER_POINTER (gnu_var_name));
6409
6410       /* Reuse an enclosing union if all fields are in the variant part
6411          and there is no representation clause on the record, to match
6412          the layout of C unions.  There is an associated check below.  */
6413       if (!gnu_field_list
6414           && TREE_CODE (gnu_record_type) == UNION_TYPE
6415           && !TYPE_PACKED (gnu_record_type))
6416         gnu_union_type = gnu_record_type;
6417       else
6418         {
6419           gnu_union_type
6420             = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6421
6422           TYPE_NAME (gnu_union_type) = gnu_union_name;
6423           TYPE_ALIGN (gnu_union_type) = 0;
6424           TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6425         }
6426
6427       for (variant = First_Non_Pragma (Variants (variant_part));
6428            Present (variant);
6429            variant = Next_Non_Pragma (variant))
6430         {
6431           tree gnu_variant_type = make_node (RECORD_TYPE);
6432           tree gnu_inner_name;
6433           tree gnu_qual;
6434
6435           Get_Variant_Encoding (variant);
6436           gnu_inner_name = get_identifier (Name_Buffer);
6437           TYPE_NAME (gnu_variant_type)
6438             = concat_id_with_name (gnu_union_name,
6439                                    IDENTIFIER_POINTER (gnu_inner_name));
6440
6441           /* Set the alignment of the inner type in case we need to make
6442              inner objects into bitfields, but then clear it out
6443              so the record actually gets only the alignment required.  */
6444           TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6445           TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6446
6447           /* Similarly, if the outer record has a size specified and all fields
6448              have record rep clauses, we can propagate the size into the
6449              variant part.  */
6450           if (all_rep_and_size)
6451             {
6452               TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6453               TYPE_SIZE_UNIT (gnu_variant_type)
6454                 = TYPE_SIZE_UNIT (gnu_record_type);
6455             }
6456
6457           /* Create the record type for the variant.  Note that we defer
6458              finalizing it until after we are sure to actually use it.  */
6459           components_to_record (gnu_variant_type, Component_List (variant),
6460                                 NULL_TREE, packed, definition,
6461                                 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6462                                 true, unchecked_union);
6463
6464           gnu_qual = choices_to_gnu (gnu_discriminant,
6465                                      Discrete_Choices (variant));
6466
6467           Set_Present_Expr (variant, annotate_value (gnu_qual));
6468
6469           /* If this is an Unchecked_Union and we have exactly one field,
6470              use this field directly to match the layout of C unions.  */
6471           if (unchecked_union
6472               && TYPE_FIELDS (gnu_variant_type)
6473               && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6474             gnu_field = TYPE_FIELDS (gnu_variant_type);
6475           else
6476             {
6477               /* Deal with packedness like in gnat_to_gnu_field.  */
6478               int field_packed
6479                 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6480
6481               /* Finalize the record type now.  We used to throw away
6482                  empty records but we no longer do that because we need
6483                  them to generate complete debug info for the variant;
6484                  otherwise, the union type definition will be lacking
6485                  the fields associated with these empty variants.  */
6486               rest_of_record_type_compilation (gnu_variant_type);
6487
6488               gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6489                                              gnu_union_type, field_packed,
6490                                              (all_rep_and_size
6491                                               ? TYPE_SIZE (gnu_variant_type)
6492                                               : 0),
6493                                              (all_rep_and_size
6494                                               ? bitsize_zero_node : 0),
6495                                              0);
6496
6497               DECL_INTERNAL_P (gnu_field) = 1;
6498
6499               if (!unchecked_union)
6500                 DECL_QUALIFIER (gnu_field) = gnu_qual;
6501             }
6502
6503           TREE_CHAIN (gnu_field) = gnu_variant_list;
6504           gnu_variant_list = gnu_field;
6505         }
6506
6507       /* Only make the QUAL_UNION_TYPE if there are any non-empty variants.  */
6508       if (gnu_variant_list)
6509         {
6510           int union_field_packed;
6511
6512           if (all_rep_and_size)
6513             {
6514               TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6515               TYPE_SIZE_UNIT (gnu_union_type)
6516                 = TYPE_SIZE_UNIT (gnu_record_type);
6517             }
6518
6519           finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6520                               all_rep_and_size ? 1 : 0, false);
6521
6522           /* If GNU_UNION_TYPE is our record type, it means we must have an
6523              Unchecked_Union with no fields.  Verify that and, if so, just
6524              return.  */
6525           if (gnu_union_type == gnu_record_type)
6526             {
6527               gcc_assert (unchecked_union
6528                           && !gnu_field_list
6529                           && !gnu_our_rep_list);
6530               return;
6531             }
6532
6533           /* Deal with packedness like in gnat_to_gnu_field.  */
6534           union_field_packed
6535             = adjust_packed (gnu_union_type, gnu_record_type, packed);
6536
6537           gnu_union_field
6538             = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6539                                  union_field_packed,
6540                                  all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6541                                  all_rep ? bitsize_zero_node : 0, 0);
6542
6543           DECL_INTERNAL_P (gnu_union_field) = 1;
6544           TREE_CHAIN (gnu_union_field) = gnu_field_list;
6545           gnu_field_list = gnu_union_field;
6546         }
6547     }
6548
6549   /* Scan GNU_FIELD_LIST and see if any fields have rep clauses.  If they
6550      do, pull them out and put them into GNU_OUR_REP_LIST.  We have to do this
6551      in a separate pass since we want to handle the discriminants but can't
6552      play with them until we've used them in debugging data above.
6553
6554      ??? Note: if we then reorder them, debugging information will be wrong,
6555      but there's nothing that can be done about this at the moment.  */
6556   for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
6557     {
6558       if (DECL_FIELD_OFFSET (gnu_field))
6559         {
6560           tree gnu_next = TREE_CHAIN (gnu_field);
6561
6562           if (!gnu_last)
6563             gnu_field_list = gnu_next;
6564           else
6565             TREE_CHAIN (gnu_last) = gnu_next;
6566
6567           TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6568           gnu_our_rep_list = gnu_field;
6569           gnu_field = gnu_next;
6570         }
6571       else
6572         {
6573           gnu_last = gnu_field;
6574           gnu_field = TREE_CHAIN (gnu_field);
6575         }
6576     }
6577
6578   /* If we have any items in our rep'ed field list, it is not the case that all
6579      the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6580      set it and ignore the items.  */
6581   if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
6582     *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
6583   else if (gnu_our_rep_list)
6584     {
6585       /* Otherwise, sort the fields by bit position and put them into their
6586          own record if we have any fields without rep clauses. */
6587       tree gnu_rep_type
6588         = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
6589       int len = list_length (gnu_our_rep_list);
6590       tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
6591       int i;
6592
6593       for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
6594            gnu_field = TREE_CHAIN (gnu_field), i++)
6595         gnu_arr[i] = gnu_field;
6596
6597       qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
6598
6599       /* Put the fields in the list in order of increasing position, which
6600          means we start from the end.  */
6601       gnu_our_rep_list = NULL_TREE;
6602       for (i = len - 1; i >= 0; i--)
6603         {
6604           TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
6605           gnu_our_rep_list = gnu_arr[i];
6606           DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
6607         }
6608
6609       if (gnu_field_list)
6610         {
6611           finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
6612           gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
6613                                          gnu_record_type, 0, 0, 0, 1);
6614           DECL_INTERNAL_P (gnu_field) = 1;
6615           gnu_field_list = chainon (gnu_field_list, gnu_field);
6616         }
6617       else
6618         {
6619           layout_with_rep = true;
6620           gnu_field_list = nreverse (gnu_our_rep_list);
6621         }
6622     }
6623
6624   if (cancel_alignment)
6625     TYPE_ALIGN (gnu_record_type) = 0;
6626
6627   finish_record_type (gnu_record_type, nreverse (gnu_field_list),
6628                       layout_with_rep ? 1 : 0, do_not_finalize);
6629 }
6630 \f
6631 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6632    placed into an Esize, Component_Bit_Offset, or Component_Size value
6633    in the GNAT tree.  */
6634
6635 static Uint
6636 annotate_value (tree gnu_size)
6637 {
6638   int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
6639   TCode tcode;
6640   Node_Ref_Or_Val ops[3], ret;
6641   int i;
6642   int size;
6643   struct tree_int_map **h = NULL;
6644
6645   /* See if we've already saved the value for this node.  */
6646   if (EXPR_P (gnu_size))
6647     {
6648       struct tree_int_map in;
6649       if (!annotate_value_cache)
6650         annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
6651                                                 tree_int_map_eq, 0);
6652       in.base.from = gnu_size;
6653       h = (struct tree_int_map **)
6654             htab_find_slot (annotate_value_cache, &in, INSERT);
6655
6656       if (*h)
6657         return (Node_Ref_Or_Val) (*h)->to;
6658     }
6659
6660   /* If we do not return inside this switch, TCODE will be set to the
6661      code to use for a Create_Node operand and LEN (set above) will be
6662      the number of recursive calls for us to make.  */
6663
6664   switch (TREE_CODE (gnu_size))
6665     {
6666     case INTEGER_CST:
6667       if (TREE_OVERFLOW (gnu_size))
6668         return No_Uint;
6669
6670       /* This may have come from a conversion from some smaller type,
6671          so ensure this is in bitsizetype.  */
6672       gnu_size = convert (bitsizetype, gnu_size);
6673
6674       /* For negative values, use NEGATE_EXPR of the supplied value.  */
6675       if (tree_int_cst_sgn (gnu_size) < 0)
6676         {
6677           /* The ridiculous code below is to handle the case of the largest
6678              negative integer.  */
6679           tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
6680           bool adjust = false;
6681           tree temp;
6682
6683           if (TREE_OVERFLOW (negative_size))
6684             {
6685               negative_size
6686                 = size_binop (MINUS_EXPR, bitsize_zero_node,
6687                               size_binop (PLUS_EXPR, gnu_size,
6688                                           bitsize_one_node));
6689               adjust = true;
6690             }
6691
6692           temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
6693           if (adjust)
6694             temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
6695
6696           return annotate_value (temp);
6697         }
6698
6699       if (!host_integerp (gnu_size, 1))
6700         return No_Uint;
6701
6702       size = tree_low_cst (gnu_size, 1);
6703
6704       /* This peculiar test is to make sure that the size fits in an int
6705          on machines where HOST_WIDE_INT is not "int".  */
6706       if (tree_low_cst (gnu_size, 1) == size)
6707         return UI_From_Int (size);
6708       else
6709         return No_Uint;
6710
6711     case COMPONENT_REF:
6712       /* The only case we handle here is a simple discriminant reference.  */
6713       if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
6714           && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
6715           && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
6716         return Create_Node (Discrim_Val,
6717                             annotate_value (DECL_DISCRIMINANT_NUMBER
6718                                             (TREE_OPERAND (gnu_size, 1))),
6719                             No_Uint, No_Uint);
6720       else
6721         return No_Uint;
6722
6723     CASE_CONVERT:   case NON_LVALUE_EXPR:
6724       return annotate_value (TREE_OPERAND (gnu_size, 0));
6725
6726       /* Now just list the operations we handle.  */
6727     case COND_EXPR:             tcode = Cond_Expr; break;
6728     case PLUS_EXPR:             tcode = Plus_Expr; break;
6729     case MINUS_EXPR:            tcode = Minus_Expr; break;
6730     case MULT_EXPR:             tcode = Mult_Expr; break;
6731     case TRUNC_DIV_EXPR:        tcode = Trunc_Div_Expr; break;
6732     case CEIL_DIV_EXPR:         tcode = Ceil_Div_Expr; break;
6733     case FLOOR_DIV_EXPR:        tcode = Floor_Div_Expr; break;
6734     case TRUNC_MOD_EXPR:        tcode = Trunc_Mod_Expr; break;
6735     case CEIL_MOD_EXPR:         tcode = Ceil_Mod_Expr; break;
6736     case FLOOR_MOD_EXPR:        tcode = Floor_Mod_Expr; break;
6737     case EXACT_DIV_EXPR:        tcode = Exact_Div_Expr; break;
6738     case NEGATE_EXPR:           tcode = Negate_Expr; break;
6739     case MIN_EXPR:              tcode = Min_Expr; break;
6740     case MAX_EXPR:              tcode = Max_Expr; break;
6741     case ABS_EXPR:              tcode = Abs_Expr; break;
6742     case TRUTH_ANDIF_EXPR:      tcode = Truth_Andif_Expr; break;
6743     case TRUTH_ORIF_EXPR:       tcode = Truth_Orif_Expr; break;
6744     case TRUTH_AND_EXPR:        tcode = Truth_And_Expr; break;
6745     case TRUTH_OR_EXPR:         tcode = Truth_Or_Expr; break;
6746     case TRUTH_XOR_EXPR:        tcode = Truth_Xor_Expr; break;
6747     case TRUTH_NOT_EXPR:        tcode = Truth_Not_Expr; break;
6748     case BIT_AND_EXPR:          tcode = Bit_And_Expr; break;
6749     case LT_EXPR:               tcode = Lt_Expr; break;
6750     case LE_EXPR:               tcode = Le_Expr; break;
6751     case GT_EXPR:               tcode = Gt_Expr; break;
6752     case GE_EXPR:               tcode = Ge_Expr; break;
6753     case EQ_EXPR:               tcode = Eq_Expr; break;
6754     case NE_EXPR:               tcode = Ne_Expr; break;
6755
6756     default:
6757       return No_Uint;
6758     }
6759
6760   /* Now get each of the operands that's relevant for this code.  If any
6761      cannot be expressed as a repinfo node, say we can't.  */
6762   for (i = 0; i < 3; i++)
6763     ops[i] = No_Uint;
6764
6765   for (i = 0; i < len; i++)
6766     {
6767       ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
6768       if (ops[i] == No_Uint)
6769         return No_Uint;
6770     }
6771
6772   ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
6773
6774   /* Save the result in the cache.  */
6775   if (h)
6776     {
6777       *h = GGC_NEW (struct tree_int_map);
6778       (*h)->base.from = gnu_size;
6779       (*h)->to = ret;
6780     }
6781
6782   return ret;
6783 }
6784
6785 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6786    GCC type, set Component_Bit_Offset and Esize to the position and size
6787    used by Gigi.  */
6788
6789 static void
6790 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
6791 {
6792   tree gnu_list;
6793   tree gnu_entry;
6794   Entity_Id gnat_field;
6795
6796   /* We operate by first making a list of all fields and their positions
6797      (we can get the sizes easily at any time) by a recursive call
6798      and then update all the sizes into the tree.  */
6799   gnu_list = compute_field_positions (gnu_type, NULL_TREE,
6800                                       size_zero_node, bitsize_zero_node,
6801                                       BIGGEST_ALIGNMENT);
6802
6803   for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
6804        gnat_field = Next_Entity (gnat_field))
6805     if ((Ekind (gnat_field) == E_Component
6806          || (Ekind (gnat_field) == E_Discriminant
6807              && !Is_Unchecked_Union (Scope (gnat_field)))))
6808       {
6809         tree parent_offset = bitsize_zero_node;
6810
6811         gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
6812                                     gnu_list);
6813
6814         if (gnu_entry)
6815           {
6816             if (type_annotate_only && Is_Tagged_Type (gnat_entity))
6817               {
6818                 /* In this mode the tag and parent components have not been
6819                    generated, so we add the appropriate offset to each
6820                    component.  For a component appearing in the current
6821                    extension, the offset is the size of the parent.  */
6822             if (Is_Derived_Type (gnat_entity)
6823                 && Original_Record_Component (gnat_field) == gnat_field)
6824               parent_offset
6825                 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
6826                              bitsizetype);
6827             else
6828               parent_offset = bitsize_int (POINTER_SIZE);
6829               }
6830
6831           Set_Component_Bit_Offset
6832             (gnat_field,
6833              annotate_value
6834              (size_binop (PLUS_EXPR,
6835                           bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
6836                                         TREE_VALUE (TREE_VALUE
6837                                                     (TREE_VALUE (gnu_entry)))),
6838                           parent_offset)));
6839
6840             Set_Esize (gnat_field,
6841                        annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
6842           }
6843         else if (Is_Tagged_Type (gnat_entity)
6844                  && Is_Derived_Type (gnat_entity))
6845           {
6846             /* If there is no gnu_entry, this is an inherited component whose
6847                position is the same as in the parent type.  */
6848             Set_Component_Bit_Offset
6849               (gnat_field,
6850                Component_Bit_Offset (Original_Record_Component (gnat_field)));
6851             Set_Esize (gnat_field,
6852                        Esize (Original_Record_Component (gnat_field)));
6853           }
6854       }
6855 }
6856
6857 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6858    FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6859    position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6860    placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position.  GNU_POS is
6861    to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6862    the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6863    so far.  */
6864
6865 static tree
6866 compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
6867                          tree gnu_bitpos, unsigned int offset_align)
6868 {
6869   tree gnu_field;
6870   tree gnu_result = gnu_list;
6871
6872   for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
6873        gnu_field = TREE_CHAIN (gnu_field))
6874     {
6875       tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
6876                                         DECL_FIELD_BIT_OFFSET (gnu_field));
6877       tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
6878                                         DECL_FIELD_OFFSET (gnu_field));
6879       unsigned int our_offset_align
6880         = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
6881
6882       gnu_result
6883         = tree_cons (gnu_field,
6884                      tree_cons (gnu_our_offset,
6885                                 tree_cons (size_int (our_offset_align),
6886                                            gnu_our_bitpos, NULL_TREE),
6887                                 NULL_TREE),
6888                      gnu_result);
6889
6890       if (DECL_INTERNAL_P (gnu_field))
6891         gnu_result
6892           = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
6893                                      gnu_our_offset, gnu_our_bitpos,
6894                                      our_offset_align);
6895     }
6896
6897   return gnu_result;
6898 }
6899 \f
6900 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6901    corresponding to GNAT_OBJECT.  If size is valid, return a tree corresponding
6902    to its value.  Otherwise return 0.  KIND is VAR_DECL is we are specifying
6903    the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6904    for the size of a field.  COMPONENT_P is true if we are being called
6905    to process the Component_Size of GNAT_OBJECT.  This is used for error
6906    message handling and to indicate to use the object size of GNU_TYPE.
6907    ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6908    it means that a size of zero should be treated as an unspecified size.  */
6909
6910 static tree
6911 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
6912                enum tree_code kind, bool component_p, bool zero_ok)
6913 {
6914   Node_Id gnat_error_node;
6915   tree type_size, size;
6916
6917   if (kind == VAR_DECL
6918       /* If a type needs strict alignment, a component of this type in
6919          a packed record cannot be packed and thus uses the type size.  */
6920       || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
6921     type_size = TYPE_SIZE (gnu_type);
6922   else
6923     type_size = rm_size (gnu_type);
6924
6925   /* Find the node to use for errors.  */
6926   if ((Ekind (gnat_object) == E_Component
6927        || Ekind (gnat_object) == E_Discriminant)
6928       && Present (Component_Clause (gnat_object)))
6929     gnat_error_node = Last_Bit (Component_Clause (gnat_object));
6930   else if (Present (Size_Clause (gnat_object)))
6931     gnat_error_node = Expression (Size_Clause (gnat_object));
6932   else
6933     gnat_error_node = gnat_object;
6934
6935   /* Return 0 if no size was specified, either because Esize was not Present or
6936      the specified size was zero.  */
6937   if (No (uint_size) || uint_size == No_Uint)
6938     return NULL_TREE;
6939
6940   /* Get the size as a tree.  Give an error if a size was specified, but cannot
6941      be represented as in sizetype. */
6942   size = UI_To_gnu (uint_size, bitsizetype);
6943   if (TREE_OVERFLOW (size))
6944     {
6945       post_error_ne (component_p ? "component size of & is too large"
6946                      : "size of & is too large",
6947                      gnat_error_node, gnat_object);
6948       return NULL_TREE;
6949     }
6950
6951   /* Ignore a negative size since that corresponds to our back-annotation.
6952      Also ignore a zero size unless a size clause exists.  */
6953   else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
6954     return NULL_TREE;
6955
6956   /* The size of objects is always a multiple of a byte.  */
6957   if (kind == VAR_DECL
6958       && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
6959     {
6960       if (component_p)
6961         post_error_ne ("component size for& is not a multiple of Storage_Unit",
6962                        gnat_error_node, gnat_object);
6963       else
6964         post_error_ne ("size for& is not a multiple of Storage_Unit",
6965                        gnat_error_node, gnat_object);
6966       return NULL_TREE;
6967     }
6968
6969   /* If this is an integral type or a packed array type, the front-end has
6970      verified the size, so we need not do it here (which would entail
6971      checking against the bounds).  However, if this is an aliased object, it
6972      may not be smaller than the type of the object.  */
6973   if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
6974       && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
6975     return size;
6976
6977   /* If the object is a record that contains a template, add the size of
6978      the template to the specified size.  */
6979   if (TREE_CODE (gnu_type) == RECORD_TYPE
6980       && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6981     size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
6982
6983   /* Modify the size of the type to be that of the maximum size if it has a
6984      discriminant.  */
6985   if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
6986     type_size = max_size (type_size, true);
6987
6988   /* If this is an access type or a fat pointer, the minimum size is that given
6989      by the smallest integral mode that's valid for pointers.  */
6990   if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
6991     {
6992       enum machine_mode p_mode;
6993
6994       for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
6995            !targetm.valid_pointer_mode (p_mode);
6996            p_mode = GET_MODE_WIDER_MODE (p_mode))
6997         ;
6998
6999       type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7000     }
7001
7002   /* If the size of the object is a constant, the new size must not be
7003      smaller.  */
7004   if (TREE_CODE (type_size) != INTEGER_CST
7005       || TREE_OVERFLOW (type_size)
7006       || tree_int_cst_lt (size, type_size))
7007     {
7008       if (component_p)
7009         post_error_ne_tree
7010           ("component size for& too small{, minimum allowed is ^}",
7011            gnat_error_node, gnat_object, type_size);
7012       else
7013         post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7014                             gnat_error_node, gnat_object, type_size);
7015
7016       if (kind == VAR_DECL && !component_p
7017           && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
7018           && !tree_int_cst_lt (size, rm_size (gnu_type)))
7019         post_error_ne_tree_2
7020           ("\\size of ^ is not a multiple of alignment (^ bits)",
7021            gnat_error_node, gnat_object, rm_size (gnu_type),
7022            TYPE_ALIGN (gnu_type));
7023
7024       else if (INTEGRAL_TYPE_P (gnu_type))
7025         post_error_ne ("\\size would be legal if & were not aliased!",
7026                        gnat_error_node, gnat_object);
7027
7028       return NULL_TREE;
7029     }
7030
7031   return size;
7032 }
7033 \f
7034 /* Similarly, but both validate and process a value of RM_Size.  This
7035    routine is only called for types.  */
7036
7037 static void
7038 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7039 {
7040   /* Only give an error if a Value_Size clause was explicitly given.
7041      Otherwise, we'd be duplicating an error on the Size clause.  */
7042   Node_Id gnat_attr_node
7043     = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7044   tree old_size = rm_size (gnu_type);
7045   tree size;
7046
7047   /* Get the size as a tree.  Do nothing if none was specified, either
7048      because RM_Size was not Present or if the specified size was zero.
7049      Give an error if a size was specified, but cannot be represented as
7050      in sizetype.  */
7051   if (No (uint_size) || uint_size == No_Uint)
7052     return;
7053
7054   size = UI_To_gnu (uint_size, bitsizetype);
7055   if (TREE_OVERFLOW (size))
7056     {
7057       if (Present (gnat_attr_node))
7058         post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7059                        gnat_entity);
7060
7061       return;
7062     }
7063
7064   /* Ignore a negative size since that corresponds to our back-annotation.
7065      Also ignore a zero size unless a size clause exists, a Value_Size
7066      clause exists, or this is an integer type, in which case the
7067      front end will have always set it.  */
7068   else if (tree_int_cst_sgn (size) < 0
7069            || (integer_zerop (size) && No (gnat_attr_node)
7070                && !Has_Size_Clause (gnat_entity)
7071                && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
7072     return;
7073
7074   /* If the old size is self-referential, get the maximum size.  */
7075   if (CONTAINS_PLACEHOLDER_P (old_size))
7076     old_size = max_size (old_size, true);
7077
7078   /* If the size of the object is a constant, the new size must not be
7079      smaller (the front end checks this for scalar types).  */
7080   if (TREE_CODE (old_size) != INTEGER_CST
7081       || TREE_OVERFLOW (old_size)
7082       || (AGGREGATE_TYPE_P (gnu_type)
7083           && tree_int_cst_lt (size, old_size)))
7084     {
7085       if (Present (gnat_attr_node))
7086         post_error_ne_tree
7087           ("Value_Size for& too small{, minimum allowed is ^}",
7088            gnat_attr_node, gnat_entity, old_size);
7089
7090       return;
7091     }
7092
7093   /* Otherwise, set the RM_Size.  */
7094   if (TREE_CODE (gnu_type) == INTEGER_TYPE
7095       && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7096     TYPE_RM_SIZE_NUM (gnu_type) = size;
7097   else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
7098     TYPE_RM_SIZE_NUM (gnu_type) = size;
7099   else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7100             || TREE_CODE (gnu_type) == UNION_TYPE
7101             || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7102            && !TYPE_IS_FAT_POINTER_P (gnu_type))
7103     SET_TYPE_ADA_SIZE (gnu_type, size);
7104 }
7105 \f
7106 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7107    If TYPE is the best type, return it.  Otherwise, make a new type.  We
7108    only support new integral and pointer types.  FOR_BIASED is nonzero if
7109    we are making a biased type.  */
7110
7111 static tree
7112 make_type_from_size (tree type, tree size_tree, bool for_biased)
7113 {
7114   unsigned HOST_WIDE_INT size;
7115   bool biased_p;
7116   tree new_type;
7117
7118   /* If size indicates an error, just return TYPE to avoid propagating
7119      the error.  Likewise if it's too large to represent.  */
7120   if (!size_tree || !host_integerp (size_tree, 1))
7121     return type;
7122
7123   size = tree_low_cst (size_tree, 1);
7124
7125   switch (TREE_CODE (type))
7126     {
7127     case INTEGER_TYPE:
7128     case ENUMERAL_TYPE:
7129       biased_p = (TREE_CODE (type) == INTEGER_TYPE
7130                   && TYPE_BIASED_REPRESENTATION_P (type));
7131
7132       /* Only do something if the type is not a packed array type and
7133          doesn't already have the proper size.  */
7134       if (TYPE_PACKED_ARRAY_TYPE_P (type)
7135           || (TYPE_PRECISION (type) == size && biased_p == for_biased))
7136         break;
7137
7138       biased_p |= for_biased;
7139       size = MIN (size, LONG_LONG_TYPE_SIZE);
7140
7141       if (TYPE_UNSIGNED (type) || biased_p)
7142         new_type = make_unsigned_type (size);
7143       else
7144         new_type = make_signed_type (size);
7145       TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7146       TYPE_MIN_VALUE (new_type)
7147         = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
7148       TYPE_MAX_VALUE (new_type)
7149         = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
7150       TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7151       TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size);
7152       return new_type;
7153
7154     case RECORD_TYPE:
7155       /* Do something if this is a fat pointer, in which case we
7156          may need to return the thin pointer.  */
7157       if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7158         return
7159           build_pointer_type
7160             (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
7161       break;
7162
7163     case POINTER_TYPE:
7164       /* Only do something if this is a thin pointer, in which case we
7165          may need to return the fat pointer.  */
7166       if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7167         return
7168           build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7169       break;
7170
7171     default:
7172       break;
7173     }
7174
7175   return type;
7176 }
7177 \f
7178 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7179    a type or object whose present alignment is ALIGN.  If this alignment is
7180    valid, return it.  Otherwise, give an error and return ALIGN.  */
7181
7182 static unsigned int
7183 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7184 {
7185   unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7186   unsigned int new_align;
7187   Node_Id gnat_error_node;
7188
7189   /* Don't worry about checking alignment if alignment was not specified
7190      by the source program and we already posted an error for this entity.  */
7191   if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7192     return align;
7193
7194   /* Post the error on the alignment clause if any.  */
7195   if (Present (Alignment_Clause (gnat_entity)))
7196     gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7197   else
7198     gnat_error_node = gnat_entity;
7199
7200   /* Within GCC, an alignment is an integer, so we must make sure a value is
7201      specified that fits in that range.  Also, there is an upper bound to
7202      alignments we can support/allow.  */
7203   if (!UI_Is_In_Int_Range (alignment)
7204       || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7205     post_error_ne_num ("largest supported alignment for& is ^",
7206                        gnat_error_node, gnat_entity, max_allowed_alignment);
7207   else if (!(Present (Alignment_Clause (gnat_entity))
7208              && From_At_Mod (Alignment_Clause (gnat_entity)))
7209            && new_align * BITS_PER_UNIT < align)
7210     post_error_ne_num ("alignment for& must be at least ^",
7211                        gnat_error_node, gnat_entity,
7212                        align / BITS_PER_UNIT);
7213   else
7214     {
7215       new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7216       if (new_align > align)
7217         align = new_align;
7218     }
7219
7220   return align;
7221 }
7222
7223 /* Return the smallest alignment not less than SIZE.  */
7224
7225 static unsigned int
7226 ceil_alignment (unsigned HOST_WIDE_INT size)
7227 {
7228   return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7229 }
7230 \f
7231 /* Verify that OBJECT, a type or decl, is something we can implement
7232    atomically.  If not, give an error for GNAT_ENTITY.  COMP_P is true
7233    if we require atomic components.  */
7234
7235 static void
7236 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7237 {
7238   Node_Id gnat_error_point = gnat_entity;
7239   Node_Id gnat_node;
7240   enum machine_mode mode;
7241   unsigned int align;
7242   tree size;
7243
7244   /* There are three case of what OBJECT can be.  It can be a type, in which
7245      case we take the size, alignment and mode from the type.  It can be a
7246      declaration that was indirect, in which case the relevant values are
7247      that of the type being pointed to, or it can be a normal declaration,
7248      in which case the values are of the decl.  The code below assumes that
7249      OBJECT is either a type or a decl.  */
7250   if (TYPE_P (object))
7251     {
7252       mode = TYPE_MODE (object);
7253       align = TYPE_ALIGN (object);
7254       size = TYPE_SIZE (object);
7255     }
7256   else if (DECL_BY_REF_P (object))
7257     {
7258       mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7259       align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7260       size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7261     }
7262   else
7263     {
7264       mode = DECL_MODE (object);
7265       align = DECL_ALIGN (object);
7266       size = DECL_SIZE (object);
7267     }
7268
7269   /* Consider all floating-point types atomic and any types that that are
7270      represented by integers no wider than a machine word.  */
7271   if (GET_MODE_CLASS (mode) == MODE_FLOAT
7272       || ((GET_MODE_CLASS (mode) == MODE_INT
7273            || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7274           && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7275     return;
7276
7277   /* For the moment, also allow anything that has an alignment equal
7278      to its size and which is smaller than a word.  */
7279   if (size && TREE_CODE (size) == INTEGER_CST
7280       && compare_tree_int (size, align) == 0
7281       && align <= BITS_PER_WORD)
7282     return;
7283
7284   for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7285        gnat_node = Next_Rep_Item (gnat_node))
7286     {
7287       if (!comp_p && Nkind (gnat_node) == N_Pragma
7288           && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7289               == Pragma_Atomic))
7290         gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7291       else if (comp_p && Nkind (gnat_node) == N_Pragma
7292                && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7293                    == Pragma_Atomic_Components))
7294         gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7295     }
7296
7297   if (comp_p)
7298     post_error_ne ("atomic access to component of & cannot be guaranteed",
7299                    gnat_error_point, gnat_entity);
7300   else
7301     post_error_ne ("atomic access to & cannot be guaranteed",
7302                    gnat_error_point, gnat_entity);
7303 }
7304 \f
7305 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7306    have compatible signatures so that a call using one type may be safely
7307    issued if the actual target function type is the other. Return 1 if it is
7308    the case, 0 otherwise, and post errors on the incompatibilities.
7309
7310    This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7311    that calls to the subprogram will have arguments suitable for the later
7312    underlying builtin expansion.  */
7313
7314 static int
7315 compatible_signatures_p (tree ftype1, tree ftype2)
7316 {
7317   /* As of now, we only perform very trivial tests and consider it's the
7318      programmer's responsibility to ensure the type correctness in the Ada
7319      declaration, as in the regular Import cases.
7320
7321      Mismatches typically result in either error messages from the builtin
7322      expander, internal compiler errors, or in a real call sequence.  This
7323      should be refined to issue diagnostics helping error detection and
7324      correction.  */
7325
7326   /* Almost fake test, ensuring a use of each argument.  */
7327   if (ftype1 == ftype2)
7328     return 1;
7329
7330   return 1;
7331 }
7332 \f
7333 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
7334    type with all size expressions that contain F updated by replacing F
7335    with R.  If F is NULL_TREE, always make a new RECORD_TYPE, even if
7336    nothing has changed.  */
7337
7338 tree
7339 substitute_in_type (tree t, tree f, tree r)
7340 {
7341   tree new = t;
7342   tree tem;
7343
7344   switch (TREE_CODE (t))
7345     {
7346     case INTEGER_TYPE:
7347     case ENUMERAL_TYPE:
7348     case BOOLEAN_TYPE:
7349       if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7350           || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7351         {
7352           tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7353           tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7354
7355           if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7356             return t;
7357
7358           new = build_range_type (TREE_TYPE (t), low, high);
7359           if (TYPE_INDEX_TYPE (t))
7360             SET_TYPE_INDEX_TYPE
7361               (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
7362           return new;
7363         }
7364
7365       return t;
7366
7367     case REAL_TYPE:
7368       if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7369           || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7370         {
7371           tree low = NULL_TREE, high = NULL_TREE;
7372
7373           if (TYPE_MIN_VALUE (t))
7374             low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7375           if (TYPE_MAX_VALUE (t))
7376             high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7377
7378           if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7379             return t;
7380
7381           t = copy_type (t);
7382           TYPE_MIN_VALUE (t) = low;
7383           TYPE_MAX_VALUE (t) = high;
7384         }
7385       return t;
7386
7387     case COMPLEX_TYPE:
7388       tem = substitute_in_type (TREE_TYPE (t), f, r);
7389       if (tem == TREE_TYPE (t))
7390         return t;
7391
7392       return build_complex_type (tem);
7393
7394     case OFFSET_TYPE:
7395     case METHOD_TYPE:
7396     case FUNCTION_TYPE:
7397     case LANG_TYPE:
7398       /* Don't know how to do these yet.  */
7399       gcc_unreachable ();
7400
7401     case ARRAY_TYPE:
7402       {
7403         tree component = substitute_in_type (TREE_TYPE (t), f, r);
7404         tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
7405
7406         if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
7407           return t;
7408
7409         new = build_array_type (component, domain);
7410         TYPE_SIZE (new) = 0;
7411         TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
7412         TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
7413         layout_type (new);
7414         TYPE_ALIGN (new) = TYPE_ALIGN (t);
7415         TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t);
7416
7417         /* If we had bounded the sizes of T by a constant, bound the sizes of
7418            NEW by the same constant.  */
7419         if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
7420           TYPE_SIZE (new)
7421             = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
7422                           TYPE_SIZE (new));
7423         if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
7424           TYPE_SIZE_UNIT (new)
7425             = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
7426                           TYPE_SIZE_UNIT (new));
7427         return new;
7428       }
7429
7430     case RECORD_TYPE:
7431     case UNION_TYPE:
7432     case QUAL_UNION_TYPE:
7433       {
7434         tree field;
7435         bool changed_field
7436           = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
7437         bool field_has_rep = false;
7438         tree last_field = NULL_TREE;
7439
7440         tree new = copy_type (t);
7441
7442         /* Start out with no fields, make new fields, and chain them
7443            in.  If we haven't actually changed the type of any field,
7444            discard everything we've done and return the old type.  */
7445
7446         TYPE_FIELDS (new) = NULL_TREE;
7447         TYPE_SIZE (new) = NULL_TREE;
7448
7449         for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
7450           {
7451             tree new_field = copy_node (field);
7452
7453             TREE_TYPE (new_field)
7454               = substitute_in_type (TREE_TYPE (new_field), f, r);
7455
7456             if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field))
7457               field_has_rep = true;
7458             else if (TREE_TYPE (new_field) != TREE_TYPE (field))
7459               changed_field = true;
7460
7461             /* If this is an internal field and the type of this field is
7462                a UNION_TYPE or RECORD_TYPE with no elements, ignore it.  If
7463                the type just has one element, treat that as the field.
7464                But don't do this if we are processing a QUAL_UNION_TYPE.  */
7465             if (TREE_CODE (t) != QUAL_UNION_TYPE
7466                 && DECL_INTERNAL_P (new_field)
7467                 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
7468                     || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
7469               {
7470                 if (!TYPE_FIELDS (TREE_TYPE (new_field)))
7471                   continue;
7472
7473                 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
7474                   {
7475                     tree next_new_field
7476                       = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
7477
7478                     /* Make sure omitting the union doesn't change
7479                        the layout.  */
7480                     DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
7481                     new_field = next_new_field;
7482                   }
7483               }
7484
7485             DECL_CONTEXT (new_field) = new;
7486             SET_DECL_ORIGINAL_FIELD (new_field,
7487                                      (DECL_ORIGINAL_FIELD (field)
7488                                       ? DECL_ORIGINAL_FIELD (field) : field));
7489
7490             /* If the size of the old field was set at a constant,
7491                propagate the size in case the type's size was variable.
7492                (This occurs in the case of a variant or discriminated
7493                record with a default size used as a field of another
7494                record.)  */
7495             DECL_SIZE (new_field)
7496               = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
7497                 ? DECL_SIZE (field) : NULL_TREE;
7498             DECL_SIZE_UNIT (new_field)
7499               = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
7500                 ? DECL_SIZE_UNIT (field) : NULL_TREE;
7501
7502             if (TREE_CODE (t) == QUAL_UNION_TYPE)
7503               {
7504                 tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
7505
7506                 if (new_q != DECL_QUALIFIER (new_field))
7507                   changed_field = true;
7508
7509                 /* Do the substitution inside the qualifier and if we find
7510                    that this field will not be present, omit it.  */
7511                 DECL_QUALIFIER (new_field) = new_q;
7512
7513                 if (integer_zerop (DECL_QUALIFIER (new_field)))
7514                   continue;
7515               }
7516
7517             if (!last_field)
7518               TYPE_FIELDS (new) = new_field;
7519             else
7520               TREE_CHAIN (last_field) = new_field;
7521
7522             last_field = new_field;
7523
7524             /* If this is a qualified type and this field will always be
7525                present, we are done.  */
7526             if (TREE_CODE (t) == QUAL_UNION_TYPE
7527                 && integer_onep (DECL_QUALIFIER (new_field)))
7528               break;
7529           }
7530
7531         /* If this used to be a qualified union type, but we now know what
7532            field will be present, make this a normal union.  */
7533         if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
7534             && (!TYPE_FIELDS (new)
7535                 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
7536           TREE_SET_CODE (new, UNION_TYPE);
7537         else if (!changed_field)
7538           return t;
7539
7540         gcc_assert (!field_has_rep);
7541         layout_type (new);
7542
7543         /* If the size was originally a constant use it.  */
7544         if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
7545             && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
7546           {
7547             TYPE_SIZE (new) = TYPE_SIZE (t);
7548             TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
7549             SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
7550           }
7551
7552         return new;
7553       }
7554
7555     default:
7556       return t;
7557     }
7558 }
7559 \f
7560 /* Return the "RM size" of GNU_TYPE.  This is the actual number of bits
7561    needed to represent the object.  */
7562
7563 tree
7564 rm_size (tree gnu_type)
7565 {
7566   /* For integer types, this is the precision.  For record types, we store
7567      the size explicitly.  For other types, this is just the size.  */
7568
7569   if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
7570     return TYPE_RM_SIZE (gnu_type);
7571   else if (TREE_CODE (gnu_type) == RECORD_TYPE
7572            && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7573     /* Return the rm_size of the actual data plus the size of the template.  */
7574     return
7575       size_binop (PLUS_EXPR,
7576                   rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
7577                   DECL_SIZE (TYPE_FIELDS (gnu_type)));
7578   else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7579             || TREE_CODE (gnu_type) == UNION_TYPE
7580             || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7581            && !TYPE_IS_FAT_POINTER_P (gnu_type)
7582            && TYPE_ADA_SIZE (gnu_type))
7583     return TYPE_ADA_SIZE (gnu_type);
7584   else
7585     return TYPE_SIZE (gnu_type);
7586 }
7587 \f
7588 /* Return an identifier representing the external name to be used for
7589    GNAT_ENTITY.  If SUFFIX is specified, the name is followed by "___"
7590    and the specified suffix.  */
7591
7592 tree
7593 create_concat_name (Entity_Id gnat_entity, const char *suffix)
7594 {
7595   Entity_Kind kind = Ekind (gnat_entity);
7596
7597   const char *str = (!suffix ? "" : suffix);
7598   String_Template temp = {1, strlen (str)};
7599   Fat_Pointer fp = {str, &temp};
7600
7601   Get_External_Name_With_Suffix (gnat_entity, fp);
7602
7603   /* A variable using the Stdcall convention (meaning we are running
7604      on a Windows box) live in a DLL. Here we adjust its name to use
7605      the jump-table, the _imp__NAME contains the address for the NAME
7606      variable. */
7607   if ((kind == E_Variable || kind == E_Constant)
7608       && Has_Stdcall_Convention (gnat_entity))
7609     {
7610       const char *prefix = "_imp__";
7611       int k, plen = strlen (prefix);
7612
7613       for (k = 0; k <= Name_Len; k++)
7614         Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
7615       strncpy (Name_Buffer, prefix, plen);
7616     }
7617
7618   return get_identifier (Name_Buffer);
7619 }
7620
7621 /* Return the name to be used for GNAT_ENTITY.  If a type, create a
7622    fully-qualified name, possibly with type information encoding.
7623    Otherwise, return the name.  */
7624
7625 tree
7626 get_entity_name (Entity_Id gnat_entity)
7627 {
7628   Get_Encoded_Name (gnat_entity);
7629   return get_identifier (Name_Buffer);
7630 }
7631
7632 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
7633    string, return a new IDENTIFIER_NODE that is the concatenation of
7634    the name in GNU_ID and SUFFIX.  */
7635
7636 tree
7637 concat_id_with_name (tree gnu_id, const char *suffix)
7638 {
7639   int len = IDENTIFIER_LENGTH (gnu_id);
7640
7641   strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), len);
7642   strncpy (Name_Buffer + len, "___", 3);
7643   len += 3;
7644   strcpy (Name_Buffer + len, suffix);
7645   return get_identifier (Name_Buffer);
7646 }
7647
7648 #include "gt-ada-decl.h"