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