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