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