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