gcc/ada/decl.c

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