gcc/ada/decl.c

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