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