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