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