gcc/ada/gcc-interface/decl.c

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