gcc/ada/decl.c

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