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