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