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