gcc/ada/utils.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                U T I L S                                 *
   6  *                                                                          *
   7  *                          C Implementation File                           *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2003, Free Software Foundation, Inc.         *
  10  *                                                                          *
  11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  12  * terms of the  GNU General Public License as published  by the Free Soft- *
  13  * ware  Foundation;  either version 2,  or (at your option) any later ver- *
  14  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  15  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  16  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  17  * for  more details.  You should have  received  a copy of the GNU General *
  18  * Public License  distributed with GNAT;  see file COPYING.  If not, write *
  19  * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
  20  * MA 02111-1307, USA.                                                      *
  21  *                                                                          *
  22  * GNAT was originally developed  by the GNAT team at  New York University. *
  23  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  24  *                                                                          *
  25  ****************************************************************************/
  26
  27 #include "config.h"
  28 #include "system.h"
  29 #include "coretypes.h"
  30 #include "tm.h"
  31 #include "tree.h"
  32 #include "flags.h"
  33 #include "defaults.h"
  34 #include "toplev.h"
  35 #include "output.h"
  36 #include "ggc.h"
  37 #include "debug.h"
  38 #include "convert.h"
  39
  40 #include "ada.h"
  41 #include "types.h"
  42 #include "atree.h"
  43 #include "elists.h"
  44 #include "namet.h"
  45 #include "nlists.h"
  46 #include "stringt.h"
  47 #include "uintp.h"
  48 #include "fe.h"
  49 #include "sinfo.h"
  50 #include "einfo.h"
  51 #include "ada-tree.h"
  52 #include "gigi.h"
  53
  54 #ifndef MAX_FIXED_MODE_SIZE
  55 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
  56 #endif
  57
  58 #ifndef MAX_BITS_PER_WORD
  59 #define MAX_BITS_PER_WORD  BITS_PER_WORD
  60 #endif
  61
  62 /* If nonzero, pretend we are allocating at global level.  */
  63 int force_global;
  64
  65 /* Tree nodes for the various types and decls we create.  */
  66 tree gnat_std_decls[(int) ADT_LAST];
  67
  68 /* Functions to call for each of the possible raise reasons.  */
  69 tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
  70
  71 /* Associates a GNAT tree node to a GCC tree node. It is used in
  72    `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
  73    of `save_gnu_tree' for more info.  */
  74 static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
  75
  76 /* This listhead is used to record any global objects that need elaboration.
  77    TREE_PURPOSE is the variable to be elaborated and TREE_VALUE is the
  78    initial value to assign.  */
  79
  80 static GTY(()) tree pending_elaborations;
  81
  82 /* This stack allows us to momentarily switch to generating elaboration
  83    lists for an inner context.  */
  84
  85 struct e_stack GTY(()) {
  86   struct e_stack *next;
  87   tree elab_list;
  88 };
  89 static GTY(()) struct e_stack *elist_stack;
  90
  91 /* This variable keeps a table for types for each precision so that we only
  92    allocate each of them once. Signed and unsigned types are kept separate.
  93
  94    Note that these types are only used when fold-const requests something
  95    special.  Perhaps we should NOT share these types; we'll see how it
  96    goes later.  */
  97 static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
  98
  99 /* Likewise for float types, but record these by mode.  */
 100 static GTY(()) tree float_types[NUM_MACHINE_MODES];
 101
 102 /* For each binding contour we allocate a binding_level structure which records
 103    the entities defined or declared in that contour. Contours include:
 104
 105         the global one
 106         one for each subprogram definition
 107         one for each compound statement (declare block)
 108
 109    Binding contours are used to create GCC tree BLOCK nodes.  */
 110
 111 struct binding_level GTY(())
 112 {
 113   /* A chain of ..._DECL nodes for all variables, constants, functions,
 114      parameters and type declarations.  These ..._DECL nodes are chained
 115      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
 116      in the reverse of the order supplied to be compatible with the
 117      back-end.  */
 118   tree names;
 119   /* For each level (except the global one), a chain of BLOCK nodes for all
 120      the levels that were entered and exited one level down from this one.  */
 121   tree blocks;
 122   /* The BLOCK node for this level, if one has been preallocated.
 123      If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 124   tree this_block;
 125   /* The binding level containing this one (the enclosing binding level). */
 126   struct binding_level *level_chain;
 127 };
 128
 129 /* The binding level currently in effect.  */
 130 static GTY(()) struct binding_level *current_binding_level;
 131
 132 /* A chain of binding_level structures awaiting reuse.  */
 133 static GTY((deletable (""))) struct binding_level *free_binding_level;
 134
 135 /* The outermost binding level. This binding level is created when the
 136    compiler is started and it will exist through the entire compilation.  */
 137 static struct binding_level *global_binding_level;
 138
 139 /* Binding level structures are initialized by copying this one.  */
 140 static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL};
 141
 142 struct language_function GTY(())
 143 {
 144   int unused;
 145 };
 146
 147 static tree merge_sizes                 PARAMS ((tree, tree, tree, int, int));
 148 static tree compute_related_constant    PARAMS ((tree, tree));
 149 static tree split_plus                  PARAMS ((tree, tree *));
 150 static int value_zerop                  PARAMS ((tree));
 151 static tree float_type_for_size         PARAMS ((int, enum machine_mode));
 152 static tree convert_to_fat_pointer      PARAMS ((tree, tree));
 153 static tree convert_to_thin_pointer     PARAMS ((tree, tree));
 154 static tree make_descriptor_field       PARAMS ((const char *,tree, tree,
 155                                                  tree));
 156 static int value_factor_p               PARAMS ((tree, int));
 157 static int potential_alignment_gap      PARAMS ((tree, tree, tree));
 158 \f
 159 /* Initialize the association of GNAT nodes to GCC trees.  */
 160
 161 void
 162 init_gnat_to_gnu ()
 163 {
 164   associate_gnat_to_gnu
 165     = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
 166
 167   pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
 168 }
 169
 170 /* GNAT_ENTITY is a GNAT tree node for an entity.   GNU_DECL is the GCC tree
 171    which is to be associated with GNAT_ENTITY. Such GCC tree node is always
 172    a ..._DECL node.  If NO_CHECK is nonzero, the latter check is suppressed.
 173
 174    If GNU_DECL is zero, a previous association is to be reset.  */
 175
 176 void
 177 save_gnu_tree (gnat_entity, gnu_decl, no_check)
 178      Entity_Id gnat_entity;
 179      tree gnu_decl;
 180      int no_check;
 181 {
 182   /* Check that GNAT_ENTITY is not already defined and that it is being set
 183      to something which is a decl.  Raise gigi 401 if not.  Usually, this
 184      means GNAT_ENTITY is defined twice, but occasionally is due to some
 185      Gigi problem.  */
 186   if (gnu_decl
 187       && (associate_gnat_to_gnu[gnat_entity - First_Node_Id]
 188           || (! no_check && ! DECL_P (gnu_decl))))
 189     gigi_abort (401);
 190
 191   associate_gnat_to_gnu[gnat_entity - First_Node_Id] = gnu_decl;
 192 }
 193
 194 /* GNAT_ENTITY is a GNAT tree node for a defining identifier.
 195    Return the ..._DECL node that was associated with it.  If there is no tree
 196    node associated with GNAT_ENTITY, abort.
 197
 198    In some cases, such as delayed elaboration or expressions that need to
 199    be elaborated only once, GNAT_ENTITY is really not an entity.  */
 200
 201 tree
 202 get_gnu_tree (gnat_entity)
 203      Entity_Id gnat_entity;
 204 {
 205   if (! associate_gnat_to_gnu[gnat_entity - First_Node_Id])
 206     gigi_abort (402);
 207
 208   return associate_gnat_to_gnu[gnat_entity - First_Node_Id];
 209 }
 210
 211 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY.  */
 212
 213 int
 214 present_gnu_tree (gnat_entity)
 215      Entity_Id gnat_entity;
 216 {
 217   return (associate_gnat_to_gnu[gnat_entity - First_Node_Id] != NULL_TREE);
 218 }
 219
 220 \f
 221 /* Return non-zero if we are currently in the global binding level.  */
 222
 223 int
 224 global_bindings_p ()
 225 {
 226   return (force_global != 0 || current_binding_level == global_binding_level
 227           ? -1 : 0);
 228 }
 229
 230 /* Return the list of declarations in the current level. Note that this list
 231    is in reverse order (it has to be so for back-end compatibility).  */
 232
 233 tree
 234 getdecls ()
 235 {
 236   return current_binding_level->names;
 237 }
 238
 239 /* Nonzero if the current level needs to have a BLOCK made.  */
 240
 241 int
 242 kept_level_p ()
 243 {
 244   return (current_binding_level->names != 0);
 245 }
 246
 247 /* Enter a new binding level. The input parameter is ignored, but has to be
 248    specified for back-end compatibility.  */
 249
 250 void
 251 pushlevel (ignore)
 252      int ignore ATTRIBUTE_UNUSED;
 253 {
 254   struct binding_level *newlevel = NULL;
 255
 256   /* Reuse a struct for this binding level, if there is one.  */
 257   if (free_binding_level)
 258     {
 259       newlevel = free_binding_level;
 260       free_binding_level = free_binding_level->level_chain;
 261     }
 262   else
 263     newlevel
 264       = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
 265
 266   *newlevel = clear_binding_level;
 267
 268   /* Add this level to the front of the chain (stack) of levels that are
 269      active.  */
 270   newlevel->level_chain = current_binding_level;
 271   current_binding_level = newlevel;
 272 }
 273
 274 /* Exit a binding level.
 275    Pop the level off, and restore the state of the identifier-decl mappings
 276    that were in effect when this level was entered.
 277
 278    If KEEP is nonzero, this level had explicit declarations, so
 279    and create a "block" (a BLOCK node) for the level
 280    to record its declarations and subblocks for symbol table output.
 281
 282    If FUNCTIONBODY is nonzero, this level is the body of a function,
 283    so create a block as if KEEP were set and also clear out all
 284    label names.
 285
 286    If REVERSE is nonzero, reverse the order of decls before putting
 287    them into the BLOCK.  */
 288
 289 tree
 290 poplevel (keep, reverse, functionbody)
 291      int keep;
 292      int reverse;
 293      int functionbody;
 294 {
 295   /* Points to a GCC BLOCK tree node. This is the BLOCK node construted for the
 296      binding level that we are about to exit and which is returned by this
 297      routine.  */
 298   tree block = NULL_TREE;
 299   tree decl_chain;
 300   tree decl_node;
 301   tree subblock_chain = current_binding_level->blocks;
 302   tree subblock_node;
 303   int block_previously_created;
 304
 305   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
 306      nodes chained through the `names' field of current_binding_level are in
 307      reverse order except for PARM_DECL node, which are explicitly stored in
 308      the right order.  */
 309   current_binding_level->names
 310     = decl_chain = (reverse) ? nreverse (current_binding_level->names)
 311       : current_binding_level->names;
 312
 313   /* Output any nested inline functions within this block which must be
 314      compiled because their address is needed. */
 315   for (decl_node = decl_chain; decl_node; decl_node = TREE_CHAIN (decl_node))
 316     if (TREE_CODE (decl_node) == FUNCTION_DECL
 317         && ! TREE_ASM_WRITTEN (decl_node) && TREE_ADDRESSABLE (decl_node)
 318         && DECL_INITIAL (decl_node) != 0)
 319       {
 320         push_function_context ();
 321         output_inline_function (decl_node);
 322         pop_function_context ();
 323       }
 324
 325   block = 0;
 326   block_previously_created = (current_binding_level->this_block != 0);
 327   if (block_previously_created)
 328     block = current_binding_level->this_block;
 329   else if (keep || functionbody)
 330     block = make_node (BLOCK);
 331   if (block != 0)
 332     {
 333       BLOCK_VARS (block) = keep ? decl_chain : 0;
 334       BLOCK_SUBBLOCKS (block) = subblock_chain;
 335     }
 336
 337   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
 338   for (subblock_node = subblock_chain; subblock_node;
 339        subblock_node = TREE_CHAIN (subblock_node))
 340     BLOCK_SUPERCONTEXT (subblock_node) = block;
 341
 342   /* Clear out the meanings of the local variables of this level.  */
 343
 344   for (subblock_node = decl_chain; subblock_node;
 345        subblock_node = TREE_CHAIN (subblock_node))
 346     if (DECL_NAME (subblock_node) != 0)
 347       /* If the identifier was used or addressed via a local extern decl,
 348          don't forget that fact.   */
 349       if (DECL_EXTERNAL (subblock_node))
 350         {
 351           if (TREE_USED (subblock_node))
 352             TREE_USED (DECL_NAME (subblock_node)) = 1;
 353           if (TREE_ADDRESSABLE (subblock_node))
 354             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
 355         }
 356
 357   {
 358     /* Pop the current level, and free the structure for reuse.  */
 359     struct binding_level *level = current_binding_level;
 360     current_binding_level = current_binding_level->level_chain;
 361     level->level_chain = free_binding_level;
 362     free_binding_level = level;
 363   }
 364
 365   if (functionbody)
 366     {
 367       /* This is the top level block of a function. The ..._DECL chain stored
 368          in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
 369          leave them in the BLOCK because they are found in the FUNCTION_DECL
 370          instead.  */
 371       DECL_INITIAL (current_function_decl) = block;
 372       BLOCK_VARS (block) = 0;
 373     }
 374   else if (block)
 375     {
 376       if (!block_previously_created)
 377         current_binding_level->blocks
 378           = chainon (current_binding_level->blocks, block);
 379     }
 380
 381   /* If we did not make a block for the level just exited, any blocks made for
 382      inner levels (since they cannot be recorded as subblocks in that level)
 383      must be carried forward so they will later become subblocks of something
 384      else.  */
 385   else if (subblock_chain)
 386     current_binding_level->blocks
 387       = chainon (current_binding_level->blocks, subblock_chain);
 388   if (block)
 389     TREE_USED (block) = 1;
 390
 391   return block;
 392 }
 393 \f
 394 /* Insert BLOCK at the end of the list of subblocks of the
 395    current binding level.  This is used when a BIND_EXPR is expanded,
 396    to handle the BLOCK node inside the BIND_EXPR.  */
 397
 398 void
 399 insert_block (block)
 400      tree block;
 401 {
 402   TREE_USED (block) = 1;
 403   current_binding_level->blocks
 404     = chainon (current_binding_level->blocks, block);
 405 }
 406
 407 /* Set the BLOCK node for the innermost scope
 408    (the one we are currently in).  */
 409
 410 void
 411 set_block (block)
 412      tree block;
 413 {
 414   current_binding_level->this_block = block;
 415   current_binding_level->names = chainon (current_binding_level->names,
 416                                           BLOCK_VARS (block));
 417   current_binding_level->blocks = chainon (current_binding_level->blocks,
 418                                            BLOCK_SUBBLOCKS (block));
 419 }
 420
 421 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
 422    Returns the ..._DECL node. */
 423
 424 tree
 425 pushdecl (decl)
 426      tree decl;
 427 {
 428   struct binding_level *b;
 429
 430   /* If at top level, there is no context. But PARM_DECLs always go in the
 431      level of its function. */
 432   if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
 433     {
 434       b = global_binding_level;
 435       DECL_CONTEXT (decl) = 0;
 436     }
 437   else
 438     {
 439       b = current_binding_level;
 440       DECL_CONTEXT (decl) = current_function_decl;
 441     }
 442
 443   /* Put the declaration on the list.  The list of declarations is in reverse
 444      order. The list will be reversed later if necessary.  This needs to be
 445      this way for compatibility with the back-end.
 446
 447      Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the list.  They
 448      will cause trouble with the debugger and aren't needed anyway.  */
 449   if (TREE_CODE (decl) != TYPE_DECL
 450       || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
 451     {
 452       TREE_CHAIN (decl) = b->names;
 453       b->names = decl;
 454     }
 455
 456   /* For the declaration of a type, set its name if it either is not already
 457      set, was set to an IDENTIFIER_NODE, indicating an internal name,
 458      or if the previous type name was not derived from a source name.
 459      We'd rather have the type named with a real name and all the pointer
 460      types to the same object have the same POINTER_TYPE node.  Code in this
 461      function in c-decl.c makes a copy of the type node here, but that may
 462      cause us trouble with incomplete types, so let's not try it (at least
 463      for now).  */
 464
 465   if (TREE_CODE (decl) == TYPE_DECL
 466       && DECL_NAME (decl) != 0
 467       && (TYPE_NAME (TREE_TYPE (decl)) == 0
 468           || TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == IDENTIFIER_NODE
 469           || (TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == TYPE_DECL
 470               && DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl)))
 471               && ! DECL_ARTIFICIAL (decl))))
 472     TYPE_NAME (TREE_TYPE (decl)) = decl;
 473
 474   return decl;
 475 }
 476 \f
 477 /* Do little here.  Set up the standard declarations later after the
 478    front end has been run.  */
 479
 480 void
 481 gnat_init_decl_processing ()
 482 {
 483   input_line = 0;
 484
 485   /* Make the binding_level structure for global names.  */
 486   current_function_decl = 0;
 487   current_binding_level = 0;
 488   free_binding_level = 0;
 489   pushlevel (0);
 490   global_binding_level = current_binding_level;
 491
 492   build_common_tree_nodes (0);
 493
 494   /* In Ada, we use a signed type for SIZETYPE.  Use the signed type
 495      corresponding to the size of Pmode.  In most cases when ptr_mode and
 496      Pmode differ, C will use the width of ptr_mode as sizetype.  But we get
 497      far better code using the width of Pmode.  Make this here since we need
 498      this before we can expand the GNAT types.  */
 499   set_sizetype (gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0));
 500   build_common_tree_nodes_2 (0);
 501
 502   pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype));
 503
 504   /* We need to make the integer type before doing anything else.
 505      We stitch this in to the appropriate GNAT type later.  */
 506   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
 507                         integer_type_node));
 508   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
 509                         char_type_node));
 510
 511   ptr_void_type_node = build_pointer_type (void_type_node);
 512
 513 }
 514
 515 /* Create the predefined scalar types such as `integer_type_node' needed
 516    in the gcc back-end and initialize the global binding level.  */
 517
 518 void
 519 init_gigi_decls (long_long_float_type, exception_type)
 520      tree long_long_float_type, exception_type;
 521 {
 522   tree endlink, decl;
 523   unsigned int i;
 524
 525   /* Set the types that GCC and Gigi use from the front end.  We would like
 526      to do this for char_type_node, but it needs to correspond to the C
 527      char type.  */
 528   if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
 529     {
 530       /* In this case, the builtin floating point types are VAX float,
 531          so make up a type for use.  */
 532       longest_float_type_node = make_node (REAL_TYPE);
 533       TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
 534       layout_type (longest_float_type_node);
 535       pushdecl (build_decl (TYPE_DECL, get_identifier ("longest float type"),
 536                             longest_float_type_node));
 537     }
 538   else
 539     longest_float_type_node = TREE_TYPE (long_long_float_type);
 540
 541   except_type_node = TREE_TYPE (exception_type);
 542
 543   unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
 544   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
 545                         unsigned_type_node));
 546
 547   void_type_decl_node
 548     = pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
 549                             void_type_node));
 550
 551   void_ftype = build_function_type (void_type_node, NULL_TREE);
 552   ptr_void_ftype = build_pointer_type (void_ftype);
 553
 554   /* Now declare runtime functions. */
 555   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
 556
 557   /* malloc is a function declaration tree for a function to allocate
 558      memory.  */
 559   malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"),
 560                                      NULL_TREE,
 561                                      build_function_type (ptr_void_type_node,
 562                                                           tree_cons (NULL_TREE,
 563                                                                      sizetype,
 564                                                                      endlink)),
 565                                      NULL_TREE, 0, 1, 1, 0);
 566
 567   /* free is a function declaration tree for a function to free memory.  */
 568   free_decl
 569     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
 570                            build_function_type (void_type_node,
 571                                                 tree_cons (NULL_TREE,
 572                                                            ptr_void_type_node,
 573                                                            endlink)),
 574                            NULL_TREE, 0, 1, 1, 0);
 575
 576   /* Make the types and functions used for exception processing.    */
 577   jmpbuf_type
 578     = build_array_type (gnat_type_for_mode (Pmode, 0),
 579                         build_index_type (build_int_2 (5, 0)));
 580   pushdecl (build_decl (TYPE_DECL, get_identifier ("JMPBUF_T"), jmpbuf_type));
 581   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
 582
 583   /* Functions to get and set the jumpbuf pointer for the current thread.  */
 584   get_jmpbuf_decl
 585     = create_subprog_decl
 586     (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
 587      NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
 588      NULL_TREE, 0, 1, 1, 0);
 589
 590   set_jmpbuf_decl
 591     = create_subprog_decl
 592     (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
 593      NULL_TREE,
 594      build_function_type (void_type_node,
 595                           tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
 596      NULL_TREE, 0, 1, 1, 0);
 597
 598   /* Function to get the current exception.  */
 599   get_excptr_decl
 600     = create_subprog_decl
 601     (get_identifier ("system__soft_links__get_gnat_exception"),
 602      NULL_TREE,
 603      build_function_type (build_pointer_type (except_type_node), NULL_TREE),
 604      NULL_TREE, 0, 1, 1, 0);
 605
 606   /* Functions that raise exceptions. */
 607   raise_nodefer_decl
 608     = create_subprog_decl
 609       (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
 610        build_function_type (void_type_node,
 611                             tree_cons (NULL_TREE,
 612                                        build_pointer_type (except_type_node),
 613                                        endlink)),
 614        NULL_TREE, 0, 1, 1, 0);
 615
 616   /* Hooks to call when entering/leaving an exception handler.  */
 617   begin_handler_decl
 618     = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
 619                            build_function_type (void_type_node,
 620                                                 tree_cons (NULL_TREE,
 621                                                            ptr_void_type_node,
 622                                                            endlink)),
 623                            NULL_TREE, 0, 1, 1, 0);
 624
 625   end_handler_decl
 626     = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
 627                            build_function_type (void_type_node,
 628                                                 tree_cons (NULL_TREE,
 629                                                            ptr_void_type_node,
 630                                                            endlink)),
 631                            NULL_TREE, 0, 1, 1, 0);
 632
 633   /* If in no exception handlers mode, all raise statements are redirected to
 634      __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
 635      this procedure will never be called in this mode.  */
 636   if (No_Exception_Handlers_Set ())
 637     {
 638       decl
 639         = create_subprog_decl
 640           (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
 641            build_function_type (void_type_node,
 642                                 tree_cons (NULL_TREE,
 643                                            build_pointer_type (char_type_node),
 644                                            tree_cons (NULL_TREE,
 645                                                       integer_type_node,
 646                                                       endlink))),
 647            NULL_TREE, 0, 1, 1, 0);
 648
 649       for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
 650         gnat_raise_decls[i] = decl;
 651     }
 652   else
 653     /* Otherwise, make one decl for each exception reason.  */
 654     for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
 655       {
 656         char name[17];
 657
 658         sprintf (name, "__gnat_rcheck_%.2d", i);
 659         gnat_raise_decls[i]
 660           = create_subprog_decl
 661             (get_identifier (name), NULL_TREE,
 662              build_function_type (void_type_node,
 663                                   tree_cons (NULL_TREE,
 664                                              build_pointer_type
 665                                              (char_type_node),
 666                                              tree_cons (NULL_TREE,
 667                                                         integer_type_node,
 668                                                         endlink))),
 669              NULL_TREE, 0, 1, 1, 0);
 670       }
 671
 672   /* Indicate that these never return.  */
 673   TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
 674   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
 675   TREE_TYPE (raise_nodefer_decl)
 676     = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
 677                             TYPE_QUAL_VOLATILE);
 678
 679   for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
 680     {
 681       TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
 682       TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
 683       TREE_TYPE (gnat_raise_decls[i])
 684         = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
 685                                 TYPE_QUAL_VOLATILE);
 686     }
 687
 688   /* setjmp returns an integer and has one operand, which is a pointer to
 689      a jmpbuf.  */
 690   setjmp_decl
 691     = create_subprog_decl
 692       (get_identifier ("setjmp"), NULL_TREE,
 693        build_function_type (integer_type_node,
 694                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, endlink)),
 695        NULL_TREE, 0, 1, 1, 0);
 696
 697   DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
 698   DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
 699
 700   main_identifier_node = get_identifier ("main");
 701 }
 702 \f
 703 /* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
 704    nodes (FIELDLIST), finish constructing the record or union type.
 705    If HAS_REP is nonzero, this record has a rep clause; don't call
 706    layout_type but merely set the size and alignment ourselves.
 707    If DEFER_DEBUG is nonzero, do not call the debugging routines
 708    on this type; it will be done later. */
 709
 710 void
 711 finish_record_type (record_type, fieldlist, has_rep, defer_debug)
 712      tree record_type;
 713      tree fieldlist;
 714      int has_rep;
 715      int defer_debug;
 716 {
 717   enum tree_code code = TREE_CODE (record_type);
 718   tree ada_size = bitsize_zero_node;
 719   tree size = bitsize_zero_node;
 720   tree size_unit = size_zero_node;
 721   int var_size = 0;
 722   tree field;
 723
 724   TYPE_FIELDS (record_type) = fieldlist;
 725
 726   if (TYPE_NAME (record_type) != 0
 727       && TREE_CODE (TYPE_NAME (record_type)) == TYPE_DECL)
 728     TYPE_STUB_DECL (record_type) = TYPE_NAME (record_type);
 729   else
 730     TYPE_STUB_DECL (record_type)
 731       = pushdecl (build_decl (TYPE_DECL, TYPE_NAME (record_type),
 732                               record_type));
 733
 734   /* We don't need both the typedef name and the record name output in
 735      the debugging information, since they are the same.  */
 736   DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1;
 737
 738   /* Globally initialize the record first.  If this is a rep'ed record,
 739      that just means some initializations; otherwise, layout the record.  */
 740
 741   if (has_rep)
 742     {
 743       TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
 744       TYPE_MODE (record_type) = BLKmode;
 745       if (TYPE_SIZE (record_type) == 0)
 746         {
 747           TYPE_SIZE (record_type) = bitsize_zero_node;
 748           TYPE_SIZE_UNIT (record_type) = size_zero_node;
 749         }
 750       /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
 751          out just like a UNION_TYPE, since the size will be fixed.  */
 752       else if (code == QUAL_UNION_TYPE)
 753         code = UNION_TYPE;
 754     }
 755   else
 756     {
 757       /* Ensure there isn't a size already set.  There can be in an error
 758          case where there is a rep clause but all fields have errors and
 759          no longer have a position.  */
 760       TYPE_SIZE (record_type) = 0;
 761       layout_type (record_type);
 762     }
 763
 764   /* At this point, the position and size of each field is known.  It was
 765      either set before entry by a rep clause, or by laying out the type
 766      above.  We now make a pass through the fields (in reverse order for
 767      QUAL_UNION_TYPEs) to compute the Ada size; the GCC size and alignment
 768      (for rep'ed records that are not padding types); and the mode (for
 769      rep'ed records).  */
 770
 771   if (code == QUAL_UNION_TYPE)
 772     fieldlist = nreverse (fieldlist);
 773
 774   for (field = fieldlist; field; field = TREE_CHAIN (field))
 775     {
 776       tree type = TREE_TYPE (field);
 777       tree this_size = DECL_SIZE (field);
 778       tree this_size_unit = DECL_SIZE_UNIT (field);
 779       tree this_ada_size = DECL_SIZE (field);
 780
 781       /* We need to make an XVE/XVU record if any field has variable size,
 782          whether or not the record does.  For example, if we have an union,
 783          it may be that all fields, rounded up to the alignment, have the
 784          same size, in which case we'll use that size.  But the debug
 785          output routines (except Dwarf2) won't be able to output the fields,
 786          so we need to make the special record.  */
 787       if (TREE_CODE (this_size) != INTEGER_CST)
 788         var_size = 1;
 789
 790       if ((TREE_CODE (type) == RECORD_TYPE || TREE_CODE (type) == UNION_TYPE
 791           || TREE_CODE (type) == QUAL_UNION_TYPE)
 792           && ! TYPE_IS_FAT_POINTER_P (type)
 793           && ! TYPE_CONTAINS_TEMPLATE_P (type)
 794           && TYPE_ADA_SIZE (type) != 0)
 795         this_ada_size = TYPE_ADA_SIZE (type);
 796
 797       if (has_rep && ! DECL_BIT_FIELD (field))
 798         TYPE_ALIGN (record_type)
 799           = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
 800
 801       switch (code)
 802         {
 803         case UNION_TYPE:
 804           ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
 805           size = size_binop (MAX_EXPR, size, this_size);
 806           size_unit = size_binop (MAX_EXPR, size_unit, this_size_unit);
 807           break;
 808
 809         case QUAL_UNION_TYPE:
 810           ada_size
 811             = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
 812                            this_ada_size, ada_size));
 813           size = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
 814                               this_size, size));
 815           size_unit = fold (build (COND_EXPR, sizetype, DECL_QUALIFIER (field),
 816                                    this_size_unit, size_unit));
 817           break;
 818
 819         case RECORD_TYPE:
 820           /* Since we know here that all fields are sorted in order of
 821              increasing bit position, the size of the record is one
 822              higher than the ending bit of the last field processed
 823              unless we have a rep clause, since in that case we might
 824              have a field outside a QUAL_UNION_TYPE that has a higher ending
 825              position.  So use a MAX in that case.  Also, if this field is a
 826              QUAL_UNION_TYPE, we need to take into account the previous size in
 827              the case of empty variants.  */
 828           ada_size
 829             = merge_sizes (ada_size, bit_position (field), this_ada_size,
 830                            TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
 831           size = merge_sizes (size, bit_position (field), this_size,
 832                               TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
 833           size_unit
 834             = merge_sizes (size_unit, byte_position (field), this_size_unit,
 835                            TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
 836           break;
 837
 838         default:
 839           abort ();
 840         }
 841     }
 842
 843   if (code == QUAL_UNION_TYPE)
 844     nreverse (fieldlist);
 845
 846   /* If this is a padding record, we never want to make the size smaller than
 847      what was specified in it, if any.  */
 848   if (TREE_CODE (record_type) == RECORD_TYPE
 849       && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type) != 0)
 850     {
 851       size = TYPE_SIZE (record_type);
 852       size_unit = TYPE_SIZE_UNIT (record_type);
 853     }
 854
 855   /* Now set any of the values we've just computed that apply.  */
 856   if (! TYPE_IS_FAT_POINTER_P (record_type)
 857       && ! TYPE_CONTAINS_TEMPLATE_P (record_type))
 858     SET_TYPE_ADA_SIZE (record_type, ada_size);
 859
 860   if (has_rep)
 861     {
 862       if (! (TREE_CODE (record_type) == RECORD_TYPE
 863              && TYPE_IS_PADDING_P (record_type)
 864              && CONTAINS_PLACEHOLDER_P (size)))
 865         {
 866           TYPE_SIZE (record_type) = round_up (size, TYPE_ALIGN (record_type));
 867           TYPE_SIZE_UNIT (record_type)
 868             = round_up (size_unit,
 869                         TYPE_ALIGN (record_type) / BITS_PER_UNIT);
 870         }
 871
 872       compute_record_mode (record_type);
 873     }
 874
 875   if (! defer_debug)
 876     {
 877       /* If this record is of variable size, rename it so that the
 878          debugger knows it is and make a new, parallel, record
 879          that tells the debugger how the record is laid out.  See
 880          exp_dbug.ads.  But don't do this for records that are padding
 881          since they confuse GDB.  */
 882       if (var_size
 883           && ! (TREE_CODE (record_type) == RECORD_TYPE
 884                 && TYPE_IS_PADDING_P (record_type)))
 885         {
 886           tree new_record_type
 887             = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
 888                          ? UNION_TYPE : TREE_CODE (record_type));
 889           tree orig_id = DECL_NAME (TYPE_STUB_DECL (record_type));
 890           tree new_id
 891             = concat_id_with_name (orig_id,
 892                                    TREE_CODE (record_type) == QUAL_UNION_TYPE
 893                                    ? "XVU" : "XVE");
 894           tree last_pos = bitsize_zero_node;
 895           tree old_field;
 896           tree prev_old_field = 0;
 897
 898           TYPE_NAME (new_record_type) = new_id;
 899           TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
 900           TYPE_STUB_DECL (new_record_type)
 901             = pushdecl (build_decl (TYPE_DECL, new_id, new_record_type));
 902           DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1;
 903           DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
 904             = DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
 905           TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
 906
 907           /* Now scan all the fields, replacing each field with a new
 908              field corresponding to the new encoding.  */
 909           for (old_field = TYPE_FIELDS (record_type); old_field != 0;
 910                old_field = TREE_CHAIN (old_field))
 911             {
 912               tree field_type = TREE_TYPE (old_field);
 913               tree field_name = DECL_NAME (old_field);
 914               tree new_field;
 915               tree curpos = bit_position (old_field);
 916               int var = 0;
 917               unsigned int align = 0;
 918               tree pos;
 919
 920               /* See how the position was modified from the last position.
 921
 922                  There are two basic cases we support: a value was added
 923                  to the last position or the last position was rounded to
 924                  a boundary and they something was added.  Check for the
 925                  first case first.  If not, see if there is any evidence
 926                  of rounding.  If so, round the last position and try
 927                  again.
 928
 929                  If this is a union, the position can be taken as zero. */
 930
 931               if (TREE_CODE (new_record_type) == UNION_TYPE)
 932                 pos = bitsize_zero_node, align = 0;
 933               else
 934                 pos = compute_related_constant (curpos, last_pos);
 935
 936               if (pos == 0 && TREE_CODE (curpos) == MULT_EXPR
 937                   && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST)
 938                 {
 939                   align = TREE_INT_CST_LOW (TREE_OPERAND (curpos, 1));
 940                   pos = compute_related_constant (curpos,
 941                                                   round_up (last_pos, align));
 942                 }
 943               else if (pos == 0 && TREE_CODE (curpos) == PLUS_EXPR
 944                        && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST
 945                        && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
 946                        && host_integerp (TREE_OPERAND
 947                                          (TREE_OPERAND (curpos, 0), 1),
 948                                          1))
 949                 {
 950                   align
 951                     = tree_low_cst
 952                       (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1);
 953                   pos = compute_related_constant (curpos,
 954                                                   round_up (last_pos, align));
 955                 }
 956               else if (potential_alignment_gap (prev_old_field, old_field,
 957                                                 pos))
 958                 {
 959                   align = TYPE_ALIGN (field_type);
 960                   pos = compute_related_constant (curpos,
 961                                                   round_up (last_pos, align));
 962                 }
 963
 964               /* If we can't compute a position, set it to zero.
 965
 966                  ??? We really should abort here, but it's too much work
 967                  to get this correct for all cases.  */
 968
 969               if (pos == 0)
 970                 pos = bitsize_zero_node;
 971
 972               /* See if this type is variable-size and make a new type
 973                  and indicate the indirection if so.  */
 974               if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
 975                 {
 976                   field_type = build_pointer_type (field_type);
 977                   var = 1;
 978                 }
 979
 980               /* Make a new field name, if necessary.  */
 981               if (var || align != 0)
 982                 {
 983                   char suffix[6];
 984
 985                   if (align != 0)
 986                     sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
 987                              align / BITS_PER_UNIT);
 988                   else
 989                     strcpy (suffix, "XVL");
 990
 991                   field_name = concat_id_with_name (field_name, suffix);
 992                 }
 993
 994               new_field = create_field_decl (field_name, field_type,
 995                                              new_record_type, 0,
 996                                              DECL_SIZE (old_field), pos, 0);
 997               TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
 998               TYPE_FIELDS (new_record_type) = new_field;
 999
1000               /* If old_field is a QUAL_UNION_TYPE, take its size as being
1001                  zero.  The only time it's not the last field of the record
1002                  is when there are other components at fixed positions after
1003                  it (meaning there was a rep clause for every field) and we
1004                  want to be able to encode them.  */
1005               last_pos = size_binop (PLUS_EXPR, bit_position (old_field),
1006                                      (TREE_CODE (TREE_TYPE (old_field))
1007                                       == QUAL_UNION_TYPE)
1008                                      ? bitsize_zero_node
1009                                      : DECL_SIZE (old_field));
1010               prev_old_field = old_field;
1011             }
1012
1013           TYPE_FIELDS (new_record_type)
1014             = nreverse (TYPE_FIELDS (new_record_type));
1015
1016           rest_of_type_compilation (new_record_type, global_bindings_p ());
1017         }
1018
1019       rest_of_type_compilation (record_type, global_bindings_p ());
1020     }
1021 }
1022
1023 /* Utility function of above to merge LAST_SIZE, the previous size of a record
1024    with FIRST_BIT and SIZE that describe a field.  SPECIAL is nonzero
1025    if this represents a QUAL_UNION_TYPE in which case we must look for
1026    COND_EXPRs and replace a value of zero with the old size.  If HAS_REP
1027    is nonzero, we must take the MAX of the end position of this field
1028    with LAST_SIZE.  In all other cases, we use FIRST_BIT plus SIZE.
1029
1030    We return an expression for the size.  */
1031
1032 static tree
1033 merge_sizes (last_size, first_bit, size, special, has_rep)
1034      tree last_size;
1035      tree first_bit, size;
1036      int special;
1037      int has_rep;
1038 {
1039   tree type = TREE_TYPE (last_size);
1040   tree new;
1041
1042   if (! special || TREE_CODE (size) != COND_EXPR)
1043     {
1044       new = size_binop (PLUS_EXPR, first_bit, size);
1045       if (has_rep)
1046         new = size_binop (MAX_EXPR, last_size, new);
1047     }
1048
1049   else
1050     new = fold (build (COND_EXPR, type, TREE_OPERAND (size, 0),
1051                        integer_zerop (TREE_OPERAND (size, 1))
1052                        ? last_size : merge_sizes (last_size, first_bit,
1053                                                   TREE_OPERAND (size, 1),
1054                                                   1, has_rep),
1055                        integer_zerop (TREE_OPERAND (size, 2))
1056                       ? last_size : merge_sizes (last_size, first_bit,
1057                                                  TREE_OPERAND (size, 2),
1058                                                  1, has_rep)));
1059
1060   /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
1061      when fed through substitute_in_expr) into thinking that a constant
1062      size is not constant.  */
1063   while (TREE_CODE (new) == NON_LVALUE_EXPR)
1064     new = TREE_OPERAND (new, 0);
1065
1066   return new;
1067 }
1068
1069 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
1070    related by the addition of a constant.  Return that constant if so.  */
1071
1072 static tree
1073 compute_related_constant (op0, op1)
1074      tree op0, op1;
1075 {
1076   tree op0_var, op1_var;
1077   tree op0_con = split_plus (op0, &op0_var);
1078   tree op1_con = split_plus (op1, &op1_var);
1079   tree result = size_binop (MINUS_EXPR, op0_con, op1_con);
1080
1081   if (operand_equal_p (op0_var, op1_var, 0))
1082     return result;
1083   else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0))
1084     return result;
1085   else
1086     return 0;
1087 }
1088
1089 /* Utility function of above to split a tree OP which may be a sum, into a
1090    constant part, which is returned, and a variable part, which is stored
1091    in *PVAR.  *PVAR may be bitsize_zero_node.  All operations must be of
1092    bitsizetype.  */
1093
1094 static tree
1095 split_plus (in, pvar)
1096      tree in;
1097      tree *pvar;
1098 {
1099   /* Strip NOPS in order to ease the tree traversal and maximize the
1100      potential for constant or plus/minus discovery. We need to be careful
1101      to always return and set *pvar to bitsizetype trees, but it's worth
1102      the effort.  */
1103   STRIP_NOPS (in);
1104
1105   *pvar = convert (bitsizetype, in);
1106
1107   if (TREE_CODE (in) == INTEGER_CST)
1108     {
1109       *pvar = bitsize_zero_node;
1110       return convert (bitsizetype, in);
1111     }
1112   else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
1113     {
1114       tree lhs_var, rhs_var;
1115       tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
1116       tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
1117
1118       if (lhs_var == TREE_OPERAND (in, 0)
1119           && rhs_var == TREE_OPERAND (in, 1))
1120         return bitsize_zero_node;
1121
1122       *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
1123       return size_binop (TREE_CODE (in), lhs_con, rhs_con);
1124     }
1125   else
1126     return bitsize_zero_node;
1127 }
1128 \f
1129 /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
1130    subprogram. If it is void_type_node, then we are dealing with a procedure,
1131    otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
1132    PARM_DECL nodes that are the subprogram arguments.  CICO_LIST is the
1133    copy-in/copy-out list to be stored into TYPE_CICO_LIST.
1134    RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
1135    object.  RETURNS_BY_REF is nonzero if the function returns by reference.
1136    RETURNS_WITH_DSP is nonzero if the function is to return with a
1137    depressed stack pointer.  */
1138
1139 tree
1140 create_subprog_type (return_type, param_decl_list, cico_list,
1141                      returns_unconstrained, returns_by_ref, returns_with_dsp)
1142      tree return_type;
1143      tree param_decl_list;
1144      tree cico_list;
1145      int returns_unconstrained, returns_by_ref, returns_with_dsp;
1146 {
1147   /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
1148      the subprogram formal parameters. This list is generated by traversing the
1149      input list of PARM_DECL nodes.  */
1150   tree param_type_list = NULL;
1151   tree param_decl;
1152   tree type;
1153
1154   for (param_decl = param_decl_list; param_decl;
1155        param_decl = TREE_CHAIN (param_decl))
1156     param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl),
1157                                           param_type_list);
1158
1159   /* The list of the function parameter types has to be terminated by the void
1160      type to signal to the back-end that we are not dealing with a variable
1161      parameter subprogram, but that the subprogram has a fixed number of
1162      parameters.  */
1163   param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list);
1164
1165   /* The list of argument types has been created in reverse
1166      so nreverse it.   */
1167   param_type_list = nreverse (param_type_list);
1168
1169   type = build_function_type (return_type, param_type_list);
1170
1171   /* TYPE may have been shared since GCC hashes types.  If it has a CICO_LIST
1172      or the new type should, make a copy of TYPE.  Likewise for
1173      RETURNS_UNCONSTRAINED and RETURNS_BY_REF.  */
1174   if (TYPE_CI_CO_LIST (type) != 0 || cico_list != 0
1175       || TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
1176       || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref)
1177     type = copy_type (type);
1178
1179   SET_TYPE_CI_CO_LIST (type, cico_list);
1180   TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained;
1181   TYPE_RETURNS_STACK_DEPRESSED (type) = returns_with_dsp;
1182   TYPE_RETURNS_BY_REF_P (type) = returns_by_ref;
1183   return type;
1184 }
1185 \f
1186 /* Return a copy of TYPE but safe to modify in any way.  */
1187
1188 tree
1189 copy_type (type)
1190      tree type;
1191 {
1192   tree new = copy_node (type);
1193
1194   /* copy_node clears this field instead of copying it, because it is
1195      aliased with TREE_CHAIN.  */
1196   TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type);
1197
1198   TYPE_POINTER_TO (new) = 0;
1199   TYPE_REFERENCE_TO (new) = 0;
1200   TYPE_MAIN_VARIANT (new) = new;
1201   TYPE_NEXT_VARIANT (new) = 0;
1202
1203   return new;
1204 }
1205 \f
1206 /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
1207    TYPE_INDEX_TYPE is INDEX.  */
1208
1209 tree
1210 create_index_type (min, max, index)
1211      tree min, max;
1212      tree index;
1213 {
1214   /* First build a type for the desired range.  */
1215   tree type = build_index_2_type (min, max);
1216
1217   /* If this type has the TYPE_INDEX_TYPE we want, return it.  Otherwise, if it
1218      doesn't have TYPE_INDEX_TYPE set, set it to INDEX.  If TYPE_INDEX_TYPE
1219      is set, but not to INDEX, make a copy of this type with the requested
1220      index type.  Note that we have no way of sharing these types, but that's
1221      only a small hole.  */
1222   if (TYPE_INDEX_TYPE (type) == index)
1223     return type;
1224   else if (TYPE_INDEX_TYPE (type) != 0)
1225     type = copy_type (type);
1226
1227   SET_TYPE_INDEX_TYPE (type, index);
1228   return type;
1229 }
1230 \f
1231 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
1232    string) and TYPE is a ..._TYPE node giving its data type.
1233    ARTIFICIAL_P is nonzero if this is a declaration that was generated
1234    by the compiler.  DEBUG_INFO_P is nonzero if we need to write debugging
1235    information about this type.  */
1236
1237 tree
1238 create_type_decl (type_name, type, attr_list, artificial_p, debug_info_p)
1239      tree type_name;
1240      tree type;
1241      struct attrib *attr_list;
1242      int artificial_p;
1243      int debug_info_p;
1244 {
1245   tree type_decl = build_decl (TYPE_DECL, type_name, type);
1246   enum tree_code code = TREE_CODE (type);
1247
1248   DECL_ARTIFICIAL (type_decl) = artificial_p;
1249   pushdecl (type_decl);
1250   process_attributes (type_decl, attr_list);
1251
1252   /* Pass type declaration information to the debugger unless this is an
1253      UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
1254      and ENUMERAL_TYPE or RECORD_TYPE which is handled separately,
1255      a dummy type, which will be completed later, or a type for which
1256      debugging information was not requested.  */
1257   if (code == UNCONSTRAINED_ARRAY_TYPE || TYPE_IS_DUMMY_P (type)
1258       || ! debug_info_p)
1259     DECL_IGNORED_P (type_decl) = 1;
1260   else if (code != ENUMERAL_TYPE && code != RECORD_TYPE
1261       && ! ((code == POINTER_TYPE || code == REFERENCE_TYPE)
1262             && TYPE_IS_DUMMY_P (TREE_TYPE (type))))
1263     rest_of_decl_compilation (type_decl, NULL, global_bindings_p (), 0);
1264
1265   return type_decl;
1266 }
1267
1268 /* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
1269    ASM_NAME is its assembler name (if provided).  TYPE is its data type
1270    (a GCC ..._TYPE node).  VAR_INIT is the GCC tree for an optional initial
1271    expression; NULL_TREE if none.
1272
1273    CONST_FLAG is nonzero if this variable is constant.
1274
1275    PUBLIC_FLAG is nonzero if this definition is to be made visible outside of
1276    the current compilation unit. This flag should be set when processing the
1277    variable definitions in a package specification.  EXTERN_FLAG is nonzero
1278    when processing an external variable declaration (as opposed to a
1279    definition: no storage is to be allocated for the variable here).
1280
1281    STATIC_FLAG is only relevant when not at top level.  In that case
1282    it indicates whether to always allocate storage to the variable.   */
1283
1284 tree
1285 create_var_decl (var_name, asm_name, type, var_init, const_flag, public_flag,
1286                  extern_flag, static_flag, attr_list)
1287      tree var_name;
1288      tree asm_name;
1289      tree type;
1290      tree var_init;
1291      int const_flag;
1292      int public_flag;
1293      int extern_flag;
1294      int static_flag;
1295      struct attrib *attr_list;
1296 {
1297   int init_const
1298     = (var_init == 0
1299        ? 0
1300        : (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
1301           && (global_bindings_p () || static_flag
1302               ? 0 != initializer_constant_valid_p (var_init,
1303                                                    TREE_TYPE (var_init))
1304               : TREE_CONSTANT (var_init))));
1305   tree var_decl
1306     = build_decl ((const_flag && init_const
1307                    /* Only make a CONST_DECL for sufficiently-small objects.
1308                       We consider complex double "sufficiently-small"  */
1309                    && TYPE_SIZE (type) != 0
1310                    && host_integerp (TYPE_SIZE_UNIT (type), 1)
1311                    && 0 >= compare_tree_int (TYPE_SIZE_UNIT (type),
1312                                              GET_MODE_SIZE (DCmode)))
1313                   ? CONST_DECL : VAR_DECL, var_name, type);
1314   tree assign_init = 0;
1315
1316   /* If this is external, throw away any initializations unless this is a
1317      CONST_DECL (meaning we have a constant); they will be done elsewhere.  If
1318      we are defining a global here, leave a constant initialization and save
1319      any variable elaborations for the elaboration routine.  Otherwise, if
1320      the initializing expression is not the same as TYPE, generate the
1321      initialization with an assignment statement, since it knows how
1322      to do the required adjustents.  If we are just annotating types,
1323      throw away the initialization if it isn't a constant.  */
1324
1325   if ((extern_flag && TREE_CODE (var_decl) != CONST_DECL)
1326       || (type_annotate_only && var_init != 0 && ! TREE_CONSTANT (var_init)))
1327     var_init = 0;
1328
1329   if (global_bindings_p () && var_init != 0 && ! init_const)
1330     {
1331       add_pending_elaborations (var_decl, var_init);
1332       var_init = 0;
1333     }
1334
1335   else if (var_init != 0
1336            && ((TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
1337                 != TYPE_MAIN_VARIANT (type))
1338                || (static_flag && ! init_const)))
1339     assign_init = var_init, var_init = 0;
1340
1341   DECL_COMMON   (var_decl) = !flag_no_common;
1342   DECL_INITIAL  (var_decl) = var_init;
1343   TREE_READONLY (var_decl) = const_flag;
1344   DECL_EXTERNAL (var_decl) = extern_flag;
1345   TREE_PUBLIC   (var_decl) = public_flag || extern_flag;
1346   TREE_CONSTANT (var_decl) = TREE_CODE (var_decl) == CONST_DECL;
1347   TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
1348     = TYPE_VOLATILE (type);
1349
1350   /* At the global binding level we need to allocate static storage for the
1351      variable if and only if its not external. If we are not at the top level
1352      we allocate automatic storage unless requested not to.  */
1353   TREE_STATIC (var_decl) = global_bindings_p () ? !extern_flag : static_flag;
1354
1355   if (asm_name != 0)
1356     SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
1357
1358   process_attributes (var_decl, attr_list);
1359
1360   /* Add this decl to the current binding level and generate any
1361      needed code and RTL. */
1362   var_decl = pushdecl (var_decl);
1363   expand_decl (var_decl);
1364
1365   if (DECL_CONTEXT (var_decl) != 0)
1366     expand_decl_init (var_decl);
1367
1368   /* If this is volatile, force it into memory.  */
1369   if (TREE_SIDE_EFFECTS (var_decl))
1370     gnat_mark_addressable (var_decl);
1371
1372   if (TREE_CODE (var_decl) != CONST_DECL)
1373     rest_of_decl_compilation (var_decl, 0, global_bindings_p (), 0);
1374
1375   if (assign_init != 0)
1376     {
1377       /* If VAR_DECL has a padded type, convert it to the unpadded
1378          type so the assignment is done properly.  */
1379       tree lhs = var_decl;
1380
1381       if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
1382           && TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
1383         lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
1384
1385       expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, lhs,
1386                                          assign_init));
1387     }
1388
1389   return var_decl;
1390 }
1391 \f
1392 /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
1393    type, and RECORD_TYPE is the type of the parent.  PACKED is nonzero if
1394    this field is in a record type with a "pragma pack".  If SIZE is nonzero
1395    it is the specified size for this field.  If POS is nonzero, it is the bit
1396    position.  If ADDRESSABLE is nonzero, it means we are allowed to take
1397    the address of this field for aliasing purposes.  */
1398
1399 tree
1400 create_field_decl (field_name, field_type, record_type, packed, size, pos,
1401                    addressable)
1402      tree field_name;
1403      tree field_type;
1404      tree record_type;
1405      int packed;
1406      tree size, pos;
1407      int addressable;
1408 {
1409   tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
1410
1411   DECL_CONTEXT (field_decl) = record_type;
1412   TREE_READONLY (field_decl) = TREE_READONLY (field_type);
1413
1414   /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1415      byte boundary since GCC cannot handle less-aligned BLKmode bitfields.  */
1416   if (packed && TYPE_MODE (field_type) == BLKmode)
1417     DECL_ALIGN (field_decl) = BITS_PER_UNIT;
1418
1419   /* If a size is specified, use it.  Otherwise, see if we have a size
1420      to use that may differ from the natural size of the object.  */
1421   if (size != 0)
1422     size = convert (bitsizetype, size);
1423   else if (packed)
1424     {
1425       if (packed == 1 && ! operand_equal_p (rm_size (field_type),
1426                                             TYPE_SIZE (field_type), 0))
1427         size = rm_size (field_type);
1428
1429       /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
1430          byte.  */
1431       if (size != 0 && TREE_CODE (size) == INTEGER_CST
1432           && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
1433         size = round_up (size, BITS_PER_UNIT);
1434     }
1435
1436   /* Make a bitfield if a size is specified for two reasons: first if the size
1437      differs from the natural size.  Second, if the alignment is insufficient.
1438      There are a number of ways the latter can be true.  But never make a
1439      bitfield if the type of the field has a nonconstant size.  */
1440
1441   if (size != 0 && TREE_CODE (size) == INTEGER_CST
1442       && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
1443       && (! operand_equal_p (TYPE_SIZE (field_type), size, 0)
1444           || (pos != 0
1445               && ! value_zerop (size_binop (TRUNC_MOD_EXPR, pos,
1446                                             bitsize_int (TYPE_ALIGN
1447                                                          (field_type)))))
1448           || packed
1449           || (TYPE_ALIGN (record_type) != 0
1450               && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
1451     {
1452       DECL_BIT_FIELD (field_decl) = 1;
1453       DECL_SIZE (field_decl) = size;
1454       if (! packed && pos == 0)
1455         DECL_ALIGN (field_decl)
1456           = (TYPE_ALIGN (record_type) != 0
1457              ? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type))
1458              : TYPE_ALIGN (field_type));
1459     }
1460
1461   DECL_PACKED (field_decl) = pos != 0 ? DECL_BIT_FIELD (field_decl) : packed;
1462   DECL_ALIGN (field_decl)
1463     = MAX (DECL_ALIGN (field_decl),
1464            DECL_BIT_FIELD (field_decl) ? 1
1465            : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT
1466            : TYPE_ALIGN (field_type));
1467
1468   if (pos != 0)
1469     {
1470       /* We need to pass in the alignment the DECL is known to have.
1471          This is the lowest-order bit set in POS, but no more than
1472          the alignment of the record, if one is specified.  Note
1473          that an alignment of 0 is taken as infinite.  */
1474       unsigned int known_align;
1475
1476       if (host_integerp (pos, 1))
1477         known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
1478       else
1479         known_align = BITS_PER_UNIT;
1480
1481       if (TYPE_ALIGN (record_type)
1482           && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
1483         known_align = TYPE_ALIGN (record_type);
1484
1485       layout_decl (field_decl, known_align);
1486       SET_DECL_OFFSET_ALIGN (field_decl,
1487                              host_integerp (pos, 1) ? BIGGEST_ALIGNMENT
1488                              : BITS_PER_UNIT);
1489       pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
1490                     &DECL_FIELD_BIT_OFFSET (field_decl),
1491                     DECL_OFFSET_ALIGN (field_decl), pos);
1492
1493       DECL_HAS_REP_P (field_decl) = 1;
1494     }
1495
1496   /* If the field type is passed by reference, we will have pointers to the
1497      field, so it is addressable. */
1498   if (must_pass_by_ref (field_type) || default_pass_by_ref (field_type))
1499     addressable = 1;
1500
1501   /* ??? For now, we say that any field of aggregate type is addressable
1502      because the front end may take 'Reference of it.  */
1503   if (AGGREGATE_TYPE_P (field_type))
1504     addressable = 1;
1505
1506   /* Mark the decl as nonaddressable if it either is indicated so semantically
1507      or if it is a bit field.  */
1508   DECL_NONADDRESSABLE_P (field_decl)
1509     = ! addressable || DECL_BIT_FIELD (field_decl);
1510
1511   return field_decl;
1512 }
1513
1514 /* Subroutine of previous function: return nonzero if EXP, ignoring any side
1515    effects, has the value of zero.  */
1516
1517 static int
1518 value_zerop (exp)
1519      tree exp;
1520 {
1521   if (TREE_CODE (exp) == COMPOUND_EXPR)
1522     return value_zerop (TREE_OPERAND (exp, 1));
1523
1524   return integer_zerop (exp);
1525 }
1526 \f
1527 /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
1528    PARAM_TYPE is its type.  READONLY is nonzero if the parameter is
1529    readonly (either an IN parameter or an address of a pass-by-ref
1530    parameter). */
1531
1532 tree
1533 create_param_decl (param_name, param_type, readonly)
1534      tree param_name;
1535      tree param_type;
1536      int readonly;
1537 {
1538   tree param_decl = build_decl (PARM_DECL, param_name, param_type);
1539
1540   /* Honor the PROMOTE_PROTOTYPES target macro, as not doing so can
1541      lead to various ABI violations.  */
1542 #ifdef PROMOTE_PROTOTYPES
1543   if ((TREE_CODE (param_type) == INTEGER_TYPE
1544        || TREE_CODE (param_type) == ENUMERAL_TYPE)
1545       && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
1546     {
1547       /* We have to be careful about biased types here.  Make a subtype
1548          of integer_type_node with the proper biasing.  */
1549       if (TREE_CODE (param_type) == INTEGER_TYPE
1550           && TYPE_BIASED_REPRESENTATION_P (param_type))
1551         {
1552           param_type
1553             = copy_type (build_range_type (integer_type_node,
1554                                            TYPE_MIN_VALUE (param_type),
1555                                            TYPE_MAX_VALUE (param_type)));
1556
1557           TYPE_BIASED_REPRESENTATION_P (param_type) = 1;
1558         }
1559       else
1560         param_type = integer_type_node;
1561     }
1562 #endif
1563
1564   DECL_ARG_TYPE (param_decl) = param_type;
1565   DECL_ARG_TYPE_AS_WRITTEN (param_decl) = param_type;
1566   TREE_READONLY (param_decl) = readonly;
1567   return param_decl;
1568 }
1569 \f
1570 /* Given a DECL and ATTR_LIST, process the listed attributes.  */
1571
1572 void
1573 process_attributes (decl, attr_list)
1574      tree decl;
1575      struct attrib *attr_list;
1576 {
1577   for (; attr_list; attr_list = attr_list->next)
1578     switch (attr_list->type)
1579       {
1580       case ATTR_MACHINE_ATTRIBUTE:
1581         decl_attributes (&decl, tree_cons (attr_list->name, attr_list->arg,
1582                                            NULL_TREE),
1583                          ATTR_FLAG_TYPE_IN_PLACE);
1584         break;
1585
1586       case ATTR_LINK_ALIAS:
1587         TREE_STATIC (decl) = 1;
1588         assemble_alias (decl, attr_list->name);
1589         break;
1590
1591       case ATTR_WEAK_EXTERNAL:
1592         if (SUPPORTS_WEAK)
1593           declare_weak (decl);
1594         else
1595           post_error ("?weak declarations not supported on this target",
1596                       attr_list->error_point);
1597         break;
1598
1599       case ATTR_LINK_SECTION:
1600 #ifdef ASM_OUTPUT_SECTION_NAME
1601         DECL_SECTION_NAME (decl)
1602           = build_string (IDENTIFIER_LENGTH (attr_list->name),
1603                           IDENTIFIER_POINTER (attr_list->name));
1604         DECL_COMMON (decl) = 0;
1605 #else
1606         post_error ("?section attributes are not supported for this target",
1607                     attr_list->error_point);
1608 #endif
1609         break;
1610       }
1611 }
1612 \f
1613 /* Add some pending elaborations on the list.  */
1614
1615 void
1616 add_pending_elaborations (var_decl, var_init)
1617      tree var_decl;
1618      tree var_init;
1619 {
1620   if (var_init != 0)
1621     Check_Elaboration_Code_Allowed (error_gnat_node);
1622
1623   pending_elaborations
1624     = chainon (pending_elaborations, build_tree_list (var_decl, var_init));
1625 }
1626
1627 /* Obtain any pending elaborations and clear the old list.  */
1628
1629 tree
1630 get_pending_elaborations ()
1631 {
1632   /* Each thing added to the list went on the end; we want it on the
1633      beginning.  */
1634   tree result = TREE_CHAIN (pending_elaborations);
1635
1636   TREE_CHAIN (pending_elaborations) = 0;
1637   return result;
1638 }
1639
1640 /* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power
1641    of 2. */
1642
1643 static int
1644 value_factor_p (value, factor)
1645      tree value;
1646      int  factor;
1647 {
1648   if (host_integerp (value, 1))
1649     return tree_low_cst (value, 1) % factor == 0;
1650
1651   if (TREE_CODE (value) == MULT_EXPR)
1652     return (value_factor_p (TREE_OPERAND (value, 0), factor)
1653             || value_factor_p (TREE_OPERAND (value, 1), factor));
1654
1655   return 0;
1656 }
1657
1658 /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
1659    unless we can prove these 2 fields are laid out in such a way that no gap
1660    exist between the end of PREV_FIELD and the begining of CURR_FIELD.  OFFSET
1661    is the distance in bits between the end of PREV_FIELD and the starting
1662    position of CURR_FIELD. It is ignored if null. */
1663
1664 static int
1665 potential_alignment_gap (prev_field, curr_field, offset)
1666      tree prev_field;
1667      tree curr_field;
1668      tree offset;
1669 {
1670   /* If this is the first field of the record, there cannot be any gap */
1671   if (!prev_field)
1672     return 0;
1673
1674   /* If the previous field is a union type, then return False: The only
1675      time when such a field is not the last field of the record is when
1676      there are other components at fixed positions after it (meaning there
1677      was a rep clause for every field), in which case we don't want the
1678      alignment constraint to override them. */
1679   if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
1680     return 0;
1681
1682   /* If the distance between the end of prev_field and the begining of
1683      curr_field is constant, then there is a gap if the value of this
1684      constant is not null. */
1685   if (offset && host_integerp (offset, 1))
1686     return (!integer_zerop (offset));
1687
1688   /* If the size and position of the previous field are constant,
1689      then check the sum of this size and position. There will be a gap
1690      iff it is not multiple of the current field alignment. */
1691   if (host_integerp (DECL_SIZE (prev_field), 1)
1692       && host_integerp (bit_position (prev_field), 1))
1693     return ((tree_low_cst (bit_position (prev_field), 1)
1694              + tree_low_cst (DECL_SIZE (prev_field), 1))
1695             % DECL_ALIGN (curr_field) != 0);
1696
1697   /* If both the position and size of the previous field are multiples
1698      of the current field alignment, there can not be any gap. */
1699   if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
1700       && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
1701     return 0;
1702
1703   /* Fallback, return that there may be a potential gap */
1704   return 1;
1705 }
1706
1707 /* Return nonzero if there are pending elaborations.  */
1708
1709 int
1710 pending_elaborations_p ()
1711 {
1712   return TREE_CHAIN (pending_elaborations) != 0;
1713 }
1714
1715 /* Save a copy of the current pending elaboration list and make a new
1716    one.  */
1717
1718 void
1719 push_pending_elaborations ()
1720 {
1721   struct e_stack *p = (struct e_stack *) ggc_alloc (sizeof (struct e_stack));
1722
1723   p->next = elist_stack;
1724   p->elab_list = pending_elaborations;
1725   elist_stack = p;
1726   pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
1727 }
1728
1729 /* Pop the stack of pending elaborations.  */
1730
1731 void
1732 pop_pending_elaborations ()
1733 {
1734   struct e_stack *p = elist_stack;
1735
1736   pending_elaborations = p->elab_list;
1737   elist_stack = p->next;
1738 }
1739
1740 /* Return the current position in pending_elaborations so we can insert
1741    elaborations after that point.  */
1742
1743 tree
1744 get_elaboration_location ()
1745 {
1746   return tree_last (pending_elaborations);
1747 }
1748
1749 /* Insert the current elaborations after ELAB, which is in some elaboration
1750    list.  */
1751
1752 void
1753 insert_elaboration_list (elab)
1754      tree elab;
1755 {
1756   tree next = TREE_CHAIN (elab);
1757
1758   if (TREE_CHAIN (pending_elaborations))
1759     {
1760       TREE_CHAIN (elab) = TREE_CHAIN (pending_elaborations);
1761       TREE_CHAIN (tree_last (pending_elaborations)) = next;
1762       TREE_CHAIN (pending_elaborations) = 0;
1763     }
1764 }
1765
1766 /* Returns a LABEL_DECL node for LABEL_NAME.  */
1767
1768 tree
1769 create_label_decl (label_name)
1770      tree label_name;
1771 {
1772   tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node);
1773
1774   DECL_CONTEXT (label_decl)     = current_function_decl;
1775   DECL_MODE (label_decl)        = VOIDmode;
1776   DECL_SOURCE_LOCATION (label_decl) = input_location;
1777
1778   return label_decl;
1779 }
1780 \f
1781 /* Returns a FUNCTION_DECL node.  SUBPROG_NAME is the name of the subprogram,
1782    ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1783    node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1784    PARM_DECL nodes chained through the TREE_CHAIN field).
1785
1786    INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
1787    appropriate fields in the FUNCTION_DECL.  */
1788
1789 tree
1790 create_subprog_decl (subprog_name, asm_name, subprog_type, param_decl_list,
1791                      inline_flag, public_flag, extern_flag, attr_list)
1792      tree subprog_name;
1793      tree asm_name;
1794      tree subprog_type;
1795      tree param_decl_list;
1796      int inline_flag;
1797      int public_flag;
1798      int extern_flag;
1799      struct attrib *attr_list;
1800 {
1801   tree return_type  = TREE_TYPE (subprog_type);
1802   tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
1803
1804   /* If this is a function nested inside an inlined external function, it
1805      means we aren't going to compile the outer function unless it is
1806      actually inlined, so do the same for us.  */
1807   if (current_function_decl != 0 && DECL_INLINE (current_function_decl)
1808       && DECL_EXTERNAL (current_function_decl))
1809     extern_flag = 1;
1810
1811   DECL_EXTERNAL (subprog_decl)  = extern_flag;
1812   TREE_PUBLIC (subprog_decl)    = public_flag;
1813   DECL_INLINE (subprog_decl)    = inline_flag;
1814   TREE_READONLY (subprog_decl)  = TYPE_READONLY (subprog_type);
1815   TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
1816   TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
1817   DECL_ARGUMENTS (subprog_decl) = param_decl_list;
1818   DECL_RESULT (subprog_decl)    = build_decl (RESULT_DECL, 0, return_type);
1819
1820   if (asm_name != 0)
1821     SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
1822
1823   process_attributes (subprog_decl, attr_list);
1824
1825   /* Add this decl to the current binding level.  */
1826   subprog_decl = pushdecl (subprog_decl);
1827
1828   /* Output the assembler code and/or RTL for the declaration.  */
1829   rest_of_decl_compilation (subprog_decl, 0, global_bindings_p (), 0);
1830
1831   return subprog_decl;
1832 }
1833 \f
1834 /* Count how deep we are into nested functions.  This is because
1835    we shouldn't call the backend function context routines unless we
1836    are in a nested function.  */
1837
1838 static int function_nesting_depth;
1839
1840 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1841    body. This routine needs to be invoked before processing the declarations
1842    appearing in the subprogram.  */
1843
1844 void
1845 begin_subprog_body (subprog_decl)
1846      tree subprog_decl;
1847 {
1848   tree param_decl_list;
1849   tree param_decl;
1850   tree next_param;
1851
1852   if (function_nesting_depth++ != 0)
1853     push_function_context ();
1854
1855   announce_function (subprog_decl);
1856
1857   /* Make this field nonzero so further routines know that this is not
1858      tentative. error_mark_node is replaced below (in poplevel) with the
1859      adequate BLOCK.  */
1860   DECL_INITIAL (subprog_decl)  = error_mark_node;
1861
1862   /* This function exists in static storage. This does not mean `static' in
1863      the C sense!  */
1864   TREE_STATIC (subprog_decl)   = 1;
1865
1866   /* Enter a new binding level.  */
1867   current_function_decl = subprog_decl;
1868   pushlevel (0);
1869
1870   /* Push all the PARM_DECL nodes onto the current scope (i.e. the scope of the
1871      subprogram body) so that they can be recognized as local variables in the
1872      subprogram.
1873
1874      The list of PARM_DECL nodes is stored in the right order in
1875      DECL_ARGUMENTS.  Since ..._DECL nodes get stored in the reverse order in
1876      which they are transmitted to `pushdecl' we need to reverse the list of
1877      PARM_DECLs if we want it to be stored in the right order. The reason why
1878      we want to make sure the PARM_DECLs are stored in the correct order is
1879      that this list will be retrieved in a few lines with a call to `getdecl'
1880      to store it back into the DECL_ARGUMENTS field.  */
1881     param_decl_list = nreverse (DECL_ARGUMENTS (subprog_decl));
1882
1883     for (param_decl = param_decl_list; param_decl; param_decl = next_param)
1884       {
1885         next_param = TREE_CHAIN (param_decl);
1886         TREE_CHAIN (param_decl) = NULL;
1887         pushdecl (param_decl);
1888       }
1889
1890   /* Store back the PARM_DECL nodes. They appear in the right order. */
1891   DECL_ARGUMENTS (subprog_decl) = getdecls ();
1892
1893   init_function_start (subprog_decl);
1894   expand_function_start (subprog_decl, 0);
1895
1896   /* If this function is `main', emit a call to `__main'
1897      to run global initializers, etc.  */
1898   if (DECL_ASSEMBLER_NAME (subprog_decl) != 0
1899       && MAIN_NAME_P (DECL_ASSEMBLER_NAME (subprog_decl))
1900       && DECL_CONTEXT (subprog_decl) == NULL_TREE)
1901     expand_main_function ();
1902 }
1903
1904 /* Finish the definition of the current subprogram and compile it all the way
1905    to assembler language output.  */
1906
1907 void
1908 end_subprog_body ()
1909 {
1910   tree decl;
1911   tree cico_list;
1912
1913   poplevel (1, 0, 1);
1914   BLOCK_SUPERCONTEXT (DECL_INITIAL (current_function_decl))
1915     = current_function_decl;
1916
1917   /* Mark the RESULT_DECL as being in this subprogram. */
1918   DECL_CONTEXT (DECL_RESULT (current_function_decl)) = current_function_decl;
1919
1920   expand_function_end ();
1921
1922   /* If this is a nested function, push a new GC context.  That will keep
1923      local variables on the stack from being collected while we're doing
1924      the compilation of this function.  */
1925   if (function_nesting_depth > 1)
1926     ggc_push_context ();
1927
1928   rest_of_compilation (current_function_decl);
1929
1930   if (function_nesting_depth > 1)
1931     ggc_pop_context ();
1932
1933   /* Throw away any VAR_DECLs we made for OUT parameters; they must
1934      not be seen when we call this function and will be in
1935      unallocated memory anyway.  */
1936   for (cico_list = TYPE_CI_CO_LIST (TREE_TYPE (current_function_decl));
1937        cico_list != 0; cico_list = TREE_CHAIN (cico_list))
1938     TREE_VALUE (cico_list) = 0;
1939
1940   if (DECL_SAVED_INSNS (current_function_decl) == 0)
1941     {
1942       /* Throw away DECL_RTL in any PARM_DECLs unless this function
1943          was saved for inline, in which case the DECL_RTLs are in
1944          preserved memory.  */
1945       for (decl = DECL_ARGUMENTS (current_function_decl);
1946            decl != 0; decl = TREE_CHAIN (decl))
1947         {
1948           SET_DECL_RTL (decl, 0);
1949           DECL_INCOMING_RTL (decl) = 0;
1950         }
1951
1952       /* Similarly, discard DECL_RTL of the return value.  */
1953       SET_DECL_RTL (DECL_RESULT (current_function_decl), 0);
1954
1955       /* But DECL_INITIAL must remain nonzero so we know this
1956          was an actual function definition unless toplev.c decided not
1957          to inline it.  */
1958       if (DECL_INITIAL (current_function_decl) != 0)
1959         DECL_INITIAL (current_function_decl) = error_mark_node;
1960
1961       DECL_ARGUMENTS (current_function_decl) = 0;
1962     }
1963
1964   /* If we are not at the bottom of the function nesting stack, pop up to
1965      the containing function.  Otherwise show we aren't in any function.  */
1966   if (--function_nesting_depth != 0)
1967     pop_function_context ();
1968   else
1969     current_function_decl = 0;
1970 }
1971 \f
1972 /* Return a definition for a builtin function named NAME and whose data type
1973    is TYPE.  TYPE should be a function type with argument types.
1974    FUNCTION_CODE tells later passes how to compile calls to this function.
1975    See tree.h for its possible values.
1976
1977    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
1978    the name to be called if we can't opencode the function.  If
1979    ATTRS is nonzero, use that for the function attribute list.  */
1980
1981 tree
1982 builtin_function (name, type, function_code, class, library_name, attrs)
1983      const char *name;
1984      tree type;
1985      int function_code;
1986      enum built_in_class class;
1987      const char *library_name;
1988      tree attrs;
1989 {
1990   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
1991
1992   DECL_EXTERNAL (decl) = 1;
1993   TREE_PUBLIC (decl) = 1;
1994   if (library_name)
1995     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
1996
1997   pushdecl (decl);
1998   DECL_BUILT_IN_CLASS (decl) = class;
1999   DECL_FUNCTION_CODE (decl) = function_code;
2000   if (attrs)
2001       decl_attributes (&decl, attrs, ATTR_FLAG_BUILT_IN);
2002   return decl;
2003 }
2004
2005 /* Return an integer type with the number of bits of precision given by
2006    PRECISION.  UNSIGNEDP is nonzero if the type is unsigned; otherwise
2007    it is a signed type.  */
2008
2009 tree
2010 gnat_type_for_size (precision, unsignedp)
2011      unsigned precision;
2012      int unsignedp;
2013 {
2014   tree t;
2015   char type_name[20];
2016
2017   if (precision <= 2 * MAX_BITS_PER_WORD
2018       && signed_and_unsigned_types[precision][unsignedp] != 0)
2019     return signed_and_unsigned_types[precision][unsignedp];
2020
2021  if (unsignedp)
2022     t = make_unsigned_type (precision);
2023   else
2024     t = make_signed_type (precision);
2025
2026   if (precision <= 2 * MAX_BITS_PER_WORD)
2027     signed_and_unsigned_types[precision][unsignedp] = t;
2028
2029   if (TYPE_NAME (t) == 0)
2030     {
2031       sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
2032       TYPE_NAME (t) = get_identifier (type_name);
2033     }
2034
2035   return t;
2036 }
2037
2038 /* Likewise for floating-point types.  */
2039
2040 static tree
2041 float_type_for_size (precision, mode)
2042      int precision;
2043      enum machine_mode mode;
2044 {
2045   tree t;
2046   char type_name[20];
2047
2048   if (float_types[(int) mode] != 0)
2049     return float_types[(int) mode];
2050
2051   float_types[(int) mode] = t = make_node (REAL_TYPE);
2052   TYPE_PRECISION (t) = precision;
2053   layout_type (t);
2054
2055   if (TYPE_MODE (t) != mode)
2056     gigi_abort (414);
2057
2058   if (TYPE_NAME (t) == 0)
2059     {
2060       sprintf (type_name, "FLOAT_%d", precision);
2061       TYPE_NAME (t) = get_identifier (type_name);
2062     }
2063
2064   return t;
2065 }
2066
2067 /* Return a data type that has machine mode MODE.  UNSIGNEDP selects
2068    an unsigned type; otherwise a signed type is returned.  */
2069
2070 tree
2071 gnat_type_for_mode (mode, unsignedp)
2072      enum machine_mode mode;
2073      int unsignedp;
2074 {
2075   if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2076     return float_type_for_size (GET_MODE_BITSIZE (mode), mode);
2077   else
2078     return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
2079 }
2080
2081 /* Return the unsigned version of a TYPE_NODE, a scalar type.  */
2082
2083 tree
2084 gnat_unsigned_type (type_node)
2085      tree type_node;
2086 {
2087   tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
2088
2089   if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2090     {
2091       type = copy_node (type);
2092       TREE_TYPE (type) = type_node;
2093     }
2094   else if (TREE_TYPE (type_node) != 0
2095            && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2096            && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2097     {
2098       type = copy_node (type);
2099       TREE_TYPE (type) = TREE_TYPE (type_node);
2100     }
2101
2102   return type;
2103 }
2104
2105 /* Return the signed version of a TYPE_NODE, a scalar type.  */
2106
2107 tree
2108 gnat_signed_type (type_node)
2109      tree type_node;
2110 {
2111   tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
2112
2113   if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2114     {
2115       type = copy_node (type);
2116       TREE_TYPE (type) = type_node;
2117     }
2118   else if (TREE_TYPE (type_node) != 0
2119            && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2120            && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2121     {
2122       type = copy_node (type);
2123       TREE_TYPE (type) = TREE_TYPE (type_node);
2124     }
2125
2126   return type;
2127 }
2128
2129 /* Return a type the same as TYPE except unsigned or signed according to
2130    UNSIGNEDP.  */
2131
2132 tree
2133 gnat_signed_or_unsigned_type (unsignedp, type)
2134      int unsignedp;
2135      tree type;
2136 {
2137   if (! INTEGRAL_TYPE_P (type) || TREE_UNSIGNED (type) == unsignedp)
2138     return type;
2139   else
2140     return gnat_type_for_size (TYPE_PRECISION (type), unsignedp);
2141 }
2142 \f
2143 /* EXP is an expression for the size of an object.  If this size contains
2144    discriminant references, replace them with the maximum (if MAX_P) or
2145    minimum (if ! MAX_P) possible value of the discriminant.  */
2146
2147 tree
2148 max_size (exp, max_p)
2149      tree exp;
2150      int max_p;
2151 {
2152   enum tree_code code = TREE_CODE (exp);
2153   tree type = TREE_TYPE (exp);
2154
2155   switch (TREE_CODE_CLASS (code))
2156     {
2157     case 'd':
2158     case 'c':
2159       return exp;
2160
2161     case 'x':
2162       if (code == TREE_LIST)
2163         return tree_cons (TREE_PURPOSE (exp),
2164                           max_size (TREE_VALUE (exp), max_p),
2165                           TREE_CHAIN (exp) != 0
2166                           ? max_size (TREE_CHAIN (exp), max_p) : 0);
2167       break;
2168
2169     case 'r':
2170       /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2171          modify.  Otherwise, we treat it like a variable.  */
2172       if (! CONTAINS_PLACEHOLDER_P (exp))
2173         return exp;
2174
2175       type = TREE_TYPE (TREE_OPERAND (exp, 1));
2176       return
2177         max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), 1);
2178
2179     case '<':
2180       return max_p ? size_one_node : size_zero_node;
2181
2182     case '1':
2183     case '2':
2184     case 'e':
2185       switch (TREE_CODE_LENGTH (code))
2186         {
2187         case 1:
2188           if (code == NON_LVALUE_EXPR)
2189             return max_size (TREE_OPERAND (exp, 0), max_p);
2190           else
2191             return
2192               fold (build1 (code, type,
2193                             max_size (TREE_OPERAND (exp, 0),
2194                                       code == NEGATE_EXPR ? ! max_p : max_p)));
2195
2196         case 2:
2197           if (code == RTL_EXPR)
2198             gigi_abort (407);
2199           else if (code == COMPOUND_EXPR)
2200             return max_size (TREE_OPERAND (exp, 1), max_p);
2201           else if (code == WITH_RECORD_EXPR)
2202             return exp;
2203
2204           {
2205             tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
2206             tree rhs = max_size (TREE_OPERAND (exp, 1),
2207                                  code == MINUS_EXPR ? ! max_p : max_p);
2208
2209             /* Special-case wanting the maximum value of a MIN_EXPR.
2210                In that case, if one side overflows, return the other.
2211                sizetype is signed, but we know sizes are non-negative.
2212                Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2213                overflowing or the maximum possible value and the RHS
2214                a variable.  */
2215             if (max_p && code == MIN_EXPR && TREE_OVERFLOW (rhs))
2216               return lhs;
2217             else if (max_p && code == MIN_EXPR && TREE_OVERFLOW (lhs))
2218               return rhs;
2219             else if ((code == MINUS_EXPR || code == PLUS_EXPR)
2220                      && ((TREE_CONSTANT (lhs) && TREE_OVERFLOW (lhs))
2221                          || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
2222                      && ! TREE_CONSTANT (rhs))
2223               return lhs;
2224             else
2225               return fold (build (code, type, lhs, rhs));
2226           }
2227
2228         case 3:
2229           if (code == SAVE_EXPR)
2230             return exp;
2231           else if (code == COND_EXPR)
2232             return fold (build (MAX_EXPR, type,
2233                                 max_size (TREE_OPERAND (exp, 1), max_p),
2234                                 max_size (TREE_OPERAND (exp, 2), max_p)));
2235           else if (code == CALL_EXPR && TREE_OPERAND (exp, 1) != 0)
2236             return build (CALL_EXPR, type, TREE_OPERAND (exp, 0),
2237                           max_size (TREE_OPERAND (exp, 1), max_p));
2238         }
2239     }
2240
2241   gigi_abort (408);
2242 }
2243 \f
2244 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2245    EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2246    Return a constructor for the template.  */
2247
2248 tree
2249 build_template (template_type, array_type, expr)
2250      tree template_type;
2251      tree array_type;
2252      tree expr;
2253 {
2254   tree template_elts = NULL_TREE;
2255   tree bound_list = NULL_TREE;
2256   tree field;
2257
2258   if (TREE_CODE (array_type) == RECORD_TYPE
2259       && (TYPE_IS_PADDING_P (array_type)
2260           || TYPE_LEFT_JUSTIFIED_MODULAR_P (array_type)))
2261     array_type = TREE_TYPE (TYPE_FIELDS (array_type));
2262
2263   if (TREE_CODE (array_type) == ARRAY_TYPE
2264       || (TREE_CODE (array_type) == INTEGER_TYPE
2265           && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
2266     bound_list = TYPE_ACTUAL_BOUNDS (array_type);
2267
2268   /* First make the list for a CONSTRUCTOR for the template.   Go down the
2269      field list of the template instead of the type chain because this
2270      array might be an Ada array of arrays and we can't tell where the
2271      nested arrays stop being the underlying object.  */
2272
2273   for (field = TYPE_FIELDS (template_type); field;
2274        (bound_list != 0
2275         ? (bound_list = TREE_CHAIN (bound_list))
2276         : (array_type = TREE_TYPE (array_type))),
2277        field = TREE_CHAIN (TREE_CHAIN (field)))
2278     {
2279       tree bounds, min, max;
2280
2281       /* If we have a bound list, get the bounds from there.  Likewise
2282          for an ARRAY_TYPE.  Otherwise, if expr is a PARM_DECL with
2283          DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2284          This will give us a maximum range.  */
2285       if (bound_list != 0)
2286         bounds = TREE_VALUE (bound_list);
2287       else if (TREE_CODE (array_type) == ARRAY_TYPE)
2288         bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
2289       else if (expr != 0 && TREE_CODE (expr) == PARM_DECL
2290                && DECL_BY_COMPONENT_PTR_P (expr))
2291         bounds = TREE_TYPE (field);
2292       else
2293         gigi_abort (411);
2294
2295       min = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MIN_VALUE (bounds));
2296       max = convert (TREE_TYPE (field), TYPE_MAX_VALUE (bounds));
2297
2298       /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2299          surround them with a WITH_RECORD_EXPR giving EXPR as the
2300          OBJECT.  */
2301       if (CONTAINS_PLACEHOLDER_P (min))
2302         min = build (WITH_RECORD_EXPR, TREE_TYPE (min), min, expr);
2303       if (CONTAINS_PLACEHOLDER_P (max))
2304         max = build (WITH_RECORD_EXPR, TREE_TYPE (max), max, expr);
2305
2306       template_elts = tree_cons (TREE_CHAIN (field), max,
2307                                  tree_cons (field, min, template_elts));
2308     }
2309
2310   return gnat_build_constructor (template_type, nreverse (template_elts));
2311 }
2312 \f
2313 /* Build a VMS descriptor from a Mechanism_Type, which must specify
2314    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
2315    in the type contains in its DECL_INITIAL the expression to use when
2316    a constructor is made for the type.  GNAT_ENTITY is a gnat node used
2317    to print out an error message if the mechanism cannot be applied to
2318    an object of that type and also for the name.  */
2319
2320 tree
2321 build_vms_descriptor (type, mech, gnat_entity)
2322      tree type;
2323      Mechanism_Type mech;
2324      Entity_Id gnat_entity;
2325 {
2326   tree record_type = make_node (RECORD_TYPE);
2327   tree field_list = 0;
2328   int class;
2329   int dtype = 0;
2330   tree inner_type;
2331   int ndim;
2332   int i;
2333   tree *idx_arr;
2334   tree tem;
2335
2336   /* If TYPE is an unconstrained array, use the underlying array type.  */
2337   if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2338     type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2339
2340   /* If this is an array, compute the number of dimensions in the array,
2341      get the index types, and point to the inner type.  */
2342   if (TREE_CODE (type) != ARRAY_TYPE)
2343     ndim = 0;
2344   else
2345     for (ndim = 1, inner_type = type;
2346          TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2347          && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2348          ndim++, inner_type = TREE_TYPE (inner_type))
2349       ;
2350
2351   idx_arr = (tree *) alloca (ndim * sizeof (tree));
2352
2353   if (mech != By_Descriptor_NCA
2354       && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2355     for (i = ndim - 1, inner_type = type;
2356          i >= 0;
2357          i--, inner_type = TREE_TYPE (inner_type))
2358       idx_arr[i] = TYPE_DOMAIN (inner_type);
2359   else
2360     for (i = 0, inner_type = type;
2361          i < ndim;
2362          i++, inner_type = TREE_TYPE (inner_type))
2363       idx_arr[i] = TYPE_DOMAIN (inner_type);
2364
2365   /* Now get the DTYPE value.  */
2366   switch (TREE_CODE (type))
2367     {
2368     case INTEGER_TYPE:
2369     case ENUMERAL_TYPE:
2370       if (TYPE_VAX_FLOATING_POINT_P (type))
2371         switch ((int) TYPE_DIGITS_VALUE (type))
2372           {
2373           case 6:
2374             dtype = 10;
2375             break;
2376           case 9:
2377             dtype = 11;
2378             break;
2379           case 15:
2380             dtype = 27;
2381             break;
2382           }
2383       else
2384         switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2385           {
2386           case 8:
2387             dtype = TREE_UNSIGNED (type) ? 2 : 6;
2388             break;
2389           case 16:
2390             dtype = TREE_UNSIGNED (type) ? 3 : 7;
2391             break;
2392           case 32:
2393             dtype = TREE_UNSIGNED (type) ? 4 : 8;
2394             break;
2395           case 64:
2396             dtype = TREE_UNSIGNED (type) ? 5 : 9;
2397             break;
2398           case 128:
2399             dtype = TREE_UNSIGNED (type) ? 25 : 26;
2400             break;
2401           }
2402       break;
2403
2404     case REAL_TYPE:
2405       dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2406       break;
2407
2408     case COMPLEX_TYPE:
2409       if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2410           && TYPE_VAX_FLOATING_POINT_P (type))
2411         switch ((int) TYPE_DIGITS_VALUE (type))
2412           {
2413           case 6:
2414             dtype = 12;
2415             break;
2416           case 9:
2417             dtype = 13;
2418             break;
2419           case 15:
2420             dtype = 29;
2421           }
2422       else
2423         dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2424       break;
2425
2426     case ARRAY_TYPE:
2427       dtype = 14;
2428       break;
2429
2430     default:
2431       break;
2432     }
2433
2434   /* Get the CLASS value.  */
2435   switch (mech)
2436     {
2437     case By_Descriptor_A:
2438       class = 4;
2439       break;
2440     case By_Descriptor_NCA:
2441       class = 10;
2442       break;
2443     case By_Descriptor_SB:
2444       class = 15;
2445       break;
2446     default:
2447       class = 1;
2448     }
2449
2450   /* Make the type for a descriptor for VMS.  The first four fields
2451      are the same for all types.  */
2452
2453   field_list
2454     = chainon (field_list,
2455                make_descriptor_field
2456                ("LENGTH", gnat_type_for_size (16, 1), record_type,
2457                 size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
2458
2459   field_list = chainon (field_list,
2460                         make_descriptor_field ("DTYPE",
2461                                                gnat_type_for_size (8, 1),
2462                                                record_type, size_int (dtype)));
2463   field_list = chainon (field_list,
2464                         make_descriptor_field ("CLASS",
2465                                                gnat_type_for_size (8, 1),
2466                                                record_type, size_int (class)));
2467
2468   field_list
2469     = chainon (field_list,
2470                make_descriptor_field ("POINTER",
2471                                       build_pointer_type (type),
2472                                       record_type,
2473                                       build1 (ADDR_EXPR,
2474                                               build_pointer_type (type),
2475                                               build (PLACEHOLDER_EXPR,
2476                                                      type))));
2477
2478   switch (mech)
2479     {
2480     case By_Descriptor:
2481     case By_Descriptor_S:
2482       break;
2483
2484     case By_Descriptor_SB:
2485       field_list
2486         = chainon (field_list,
2487                    make_descriptor_field
2488                    ("SB_L1", gnat_type_for_size (32, 1), record_type,
2489                     TREE_CODE (type) == ARRAY_TYPE
2490                     ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
2491       field_list
2492         = chainon (field_list,
2493                    make_descriptor_field
2494                    ("SB_L2", gnat_type_for_size (32, 1), record_type,
2495                     TREE_CODE (type) == ARRAY_TYPE
2496                     ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
2497       break;
2498
2499     case By_Descriptor_A:
2500     case By_Descriptor_NCA:
2501       field_list = chainon (field_list,
2502                             make_descriptor_field ("SCALE",
2503                                                    gnat_type_for_size (8, 1),
2504                                                    record_type,
2505                                                    size_zero_node));
2506
2507       field_list = chainon (field_list,
2508                             make_descriptor_field ("DIGITS",
2509                                                    gnat_type_for_size (8, 1),
2510                                                    record_type,
2511                                                    size_zero_node));
2512
2513       field_list
2514         = chainon (field_list,
2515                    make_descriptor_field
2516                    ("AFLAGS", gnat_type_for_size (8, 1), record_type,
2517                     size_int (mech == By_Descriptor_NCA
2518                               ? 0
2519                               /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS.  */
2520                               : (TREE_CODE (type) == ARRAY_TYPE
2521                                  && TYPE_CONVENTION_FORTRAN_P (type)
2522                                  ? 224 : 192))));
2523
2524       field_list = chainon (field_list,
2525                             make_descriptor_field ("DIMCT",
2526                                                    gnat_type_for_size (8, 1),
2527                                                    record_type,
2528                                                    size_int (ndim)));
2529
2530       field_list = chainon (field_list,
2531                             make_descriptor_field ("ARSIZE",
2532                                                    gnat_type_for_size (32, 1),
2533                                                    record_type,
2534                                                    size_in_bytes (type)));
2535
2536       /* Now build a pointer to the 0,0,0... element.  */
2537       tem = build (PLACEHOLDER_EXPR, type);
2538       for (i = 0, inner_type = type; i < ndim;
2539            i++, inner_type = TREE_TYPE (inner_type))
2540         tem = build (ARRAY_REF, TREE_TYPE (inner_type), tem,
2541                      convert (TYPE_DOMAIN (inner_type), size_zero_node));
2542
2543       field_list
2544         = chainon (field_list,
2545                    make_descriptor_field
2546                    ("A0", build_pointer_type (inner_type), record_type,
2547                     build1 (ADDR_EXPR, build_pointer_type (inner_type), tem)));
2548
2549       /* Next come the addressing coefficients.  */
2550       tem = size_int (1);
2551       for (i = 0; i < ndim; i++)
2552         {
2553           char fname[3];
2554           tree idx_length
2555             = size_binop (MULT_EXPR, tem,
2556                           size_binop (PLUS_EXPR,
2557                                       size_binop (MINUS_EXPR,
2558                                                   TYPE_MAX_VALUE (idx_arr[i]),
2559                                                   TYPE_MIN_VALUE (idx_arr[i])),
2560                                       size_int (1)));
2561
2562           fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
2563           fname[1] = '0' + i, fname[2] = 0;
2564           field_list
2565             = chainon (field_list,
2566                        make_descriptor_field (fname,
2567                                               gnat_type_for_size (32, 1),
2568                                               record_type, idx_length));
2569
2570           if (mech == By_Descriptor_NCA)
2571             tem = idx_length;
2572         }
2573
2574       /* Finally here are the bounds.  */
2575       for (i = 0; i < ndim; i++)
2576         {
2577           char fname[3];
2578
2579           fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
2580           field_list
2581             = chainon (field_list,
2582                        make_descriptor_field
2583                        (fname, gnat_type_for_size (32, 1), record_type,
2584                         TYPE_MIN_VALUE (idx_arr[i])));
2585
2586           fname[0] = 'U';
2587           field_list
2588             = chainon (field_list,
2589                        make_descriptor_field
2590                        (fname, gnat_type_for_size (32, 1), record_type,
2591                         TYPE_MAX_VALUE (idx_arr[i])));
2592         }
2593       break;
2594
2595     default:
2596       post_error ("unsupported descriptor type for &", gnat_entity);
2597     }
2598
2599   finish_record_type (record_type, field_list, 0, 1);
2600   pushdecl (build_decl (TYPE_DECL, create_concat_name (gnat_entity, "DESC"),
2601                         record_type));
2602
2603   return record_type;
2604 }
2605
2606 /* Utility routine for above code to make a field.  */
2607
2608 static tree
2609 make_descriptor_field (name, type, rec_type, initial)
2610      const char *name;
2611      tree type;
2612      tree rec_type;
2613      tree initial;
2614 {
2615   tree field
2616     = create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
2617
2618   DECL_INITIAL (field) = initial;
2619   return field;
2620 }
2621 \f
2622 /* Build a type to be used to represent an aliased object whose nominal
2623    type is an unconstrained array.  This consists of a RECORD_TYPE containing
2624    a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
2625    ARRAY_TYPE.  If ARRAY_TYPE is that of the unconstrained array, this
2626    is used to represent an arbitrary unconstrained object.  Use NAME
2627    as the name of the record.  */
2628
2629 tree
2630 build_unc_object_type (template_type, object_type, name)
2631      tree template_type;
2632      tree object_type;
2633      tree name;
2634 {
2635   tree type = make_node (RECORD_TYPE);
2636   tree template_field = create_field_decl (get_identifier ("BOUNDS"),
2637                                            template_type, type, 0, 0, 0, 1);
2638   tree array_field = create_field_decl (get_identifier ("ARRAY"), object_type,
2639                                         type, 0, 0, 0, 1);
2640
2641   TYPE_NAME (type) = name;
2642   TYPE_CONTAINS_TEMPLATE_P (type) = 1;
2643   finish_record_type (type,
2644                       chainon (chainon (NULL_TREE, template_field),
2645                                array_field),
2646                       0, 0);
2647
2648   return type;
2649 }
2650 \f
2651 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.  In
2652    the normal case this is just two adjustments, but we have more to do
2653    if NEW is an UNCONSTRAINED_ARRAY_TYPE.  */
2654
2655 void
2656 update_pointer_to (old_type, new_type)
2657      tree old_type;
2658      tree new_type;
2659 {
2660   tree ptr = TYPE_POINTER_TO (old_type);
2661   tree ref = TYPE_REFERENCE_TO (old_type);
2662   tree type;
2663
2664   /* If this is the main variant, process all the other variants first.  */
2665   if (TYPE_MAIN_VARIANT (old_type) == old_type)
2666     for (type = TYPE_NEXT_VARIANT (old_type); type != 0;
2667          type = TYPE_NEXT_VARIANT (type))
2668       update_pointer_to (type, new_type);
2669
2670   /* If no pointer or reference, we are done.  */
2671   if (ptr == 0 && ref == 0)
2672     return;
2673
2674   /* Merge the old type qualifiers in the new type.
2675
2676      Each old variant has qualifiers for specific reasons, and the new
2677      designated type as well. Each set of qualifiers represents useful
2678      information grabbed at some point, and merging the two simply unifies
2679      these inputs into the final type description.
2680
2681      Consider for instance a volatile type frozen after an access to constant
2682      type designating it. After the designated type freeze, we get here with a
2683      volatile new_type and a dummy old_type with a readonly variant, created
2684      when the access type was processed. We shall make a volatile and readonly
2685      designated type, because that's what it really is.
2686
2687      We might also get here for a non-dummy old_type variant with different
2688      qualifiers than the new_type ones, for instance in some cases of pointers
2689      to private record type elaboration (see the comments around the call to
2690      this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the
2691      qualifiers in thoses cases too, to avoid accidentally discarding the
2692      initial set, and will often end up with old_type == new_type then.  */
2693   new_type = build_qualified_type (new_type,
2694                                    TYPE_QUALS (old_type)
2695                                    | TYPE_QUALS (new_type));
2696
2697   /* If the new type and the old one are identical, there is nothing to
2698      update.  */
2699   if (old_type == new_type)
2700     return;
2701
2702   /* Otherwise, first handle the simple case.  */
2703   if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
2704     {
2705       if (ptr != 0)
2706         TREE_TYPE (ptr) = new_type;
2707       TYPE_POINTER_TO (new_type) = ptr;
2708
2709       if (ref != 0)
2710         TREE_TYPE (ref) = new_type;
2711       TYPE_REFERENCE_TO (new_type) = ref;
2712
2713       if (ptr != 0 && TYPE_NAME (ptr) != 0
2714           && TREE_CODE (TYPE_NAME (ptr)) == TYPE_DECL
2715           && TREE_CODE (new_type) != ENUMERAL_TYPE)
2716         rest_of_decl_compilation (TYPE_NAME (ptr), NULL,
2717                                   global_bindings_p (), 0);
2718       if (ref != 0 && TYPE_NAME (ref) != 0
2719           && TREE_CODE (TYPE_NAME (ref)) == TYPE_DECL
2720           && TREE_CODE (new_type) != ENUMERAL_TYPE)
2721         rest_of_decl_compilation (TYPE_NAME (ref), NULL,
2722                                   global_bindings_p (), 0);
2723     }
2724
2725   /* Now deal with the unconstrained array case. In this case the "pointer"
2726      is actually a RECORD_TYPE where the types of both fields are
2727      pointers to void.  In that case, copy the field list from the
2728      old type to the new one and update the fields' context. */
2729   else if (TREE_CODE (ptr) != RECORD_TYPE || ! TYPE_IS_FAT_POINTER_P (ptr))
2730     gigi_abort (412);
2731
2732   else
2733     {
2734       tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type);
2735       tree ptr_temp_type;
2736       tree new_ref;
2737       tree var;
2738
2739       TYPE_FIELDS (ptr) = TYPE_FIELDS (TYPE_POINTER_TO (new_type));
2740       DECL_CONTEXT (TYPE_FIELDS (ptr)) = ptr;
2741       DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr))) = ptr;
2742
2743       /* Rework the PLACEHOLDER_EXPR inside the reference to the
2744          template bounds.
2745
2746          ??? This is now the only use of gnat_substitute_in_type, which
2747          is now a very "heavy" routine to do this, so it should be replaced
2748          at some point.  */
2749       ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr)));
2750       new_ref = build (COMPONENT_REF, ptr_temp_type,
2751                        build (PLACEHOLDER_EXPR, ptr),
2752                        TREE_CHAIN (TYPE_FIELDS (ptr)));
2753
2754       update_pointer_to
2755         (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
2756          gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
2757                                   TREE_CHAIN (TYPE_FIELDS (ptr)), new_ref));
2758
2759       for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var))
2760         SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type);
2761
2762       TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type)
2763         = TREE_TYPE (new_type) = ptr;
2764
2765       /* Now handle updating the allocation record, what the thin pointer
2766          points to.  Update all pointers from the old record into the new
2767          one, update the types of the fields, and recompute the size.  */
2768
2769       update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec);
2770
2771       TREE_TYPE (TYPE_FIELDS (new_obj_rec)) = TREE_TYPE (ptr_temp_type);
2772       TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
2773         = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr)));
2774       DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
2775         = TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
2776       DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
2777         = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
2778
2779       TYPE_SIZE (new_obj_rec)
2780         = size_binop (PLUS_EXPR,
2781                       DECL_SIZE (TYPE_FIELDS (new_obj_rec)),
2782                       DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
2783       TYPE_SIZE_UNIT (new_obj_rec)
2784         = size_binop (PLUS_EXPR,
2785                       DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec)),
2786                       DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
2787       rest_of_type_compilation (ptr, global_bindings_p ());
2788     }
2789 }
2790 \f
2791 /* Convert a pointer to a constrained array into a pointer to a fat
2792    pointer.  This involves making or finding a template.  */
2793
2794 static tree
2795 convert_to_fat_pointer (type, expr)
2796      tree type;
2797      tree expr;
2798 {
2799   tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))));
2800   tree template, template_addr;
2801   tree etype = TREE_TYPE (expr);
2802
2803   /* If EXPR is a constant of zero, we make a fat pointer that has a null
2804      pointer to the template and array.  */
2805   if (integer_zerop (expr))
2806     return
2807       gnat_build_constructor
2808         (type,
2809          tree_cons (TYPE_FIELDS (type),
2810                     convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
2811                     tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
2812                                convert (build_pointer_type (template_type),
2813                                         expr),
2814                                NULL_TREE)));
2815
2816   /* If EXPR is a thin pointer, make the template and data from the record.  */
2817
2818   else if (TYPE_THIN_POINTER_P (etype))
2819     {
2820       tree fields = TYPE_FIELDS (TREE_TYPE (etype));
2821
2822       expr = save_expr (expr);
2823       if (TREE_CODE (expr) == ADDR_EXPR)
2824         expr = TREE_OPERAND (expr, 0);
2825       else
2826         expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
2827
2828       template = build_component_ref (expr, NULL_TREE, fields, 0);
2829       expr = build_unary_op (ADDR_EXPR, NULL_TREE,
2830                              build_component_ref (expr, NULL_TREE,
2831                                                   TREE_CHAIN (fields), 0));
2832     }
2833   else
2834     /* Otherwise, build the constructor for the template.  */
2835     template = build_template (template_type, TREE_TYPE (etype), expr);
2836
2837   template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
2838
2839   /* The result is a CONSTRUCTOR for the fat pointer.
2840
2841      If expr is an argument of a foreign convention subprogram, the type it
2842      points to is directly the component type. In this case, the expression
2843      type may not match the corresponding FIELD_DECL type at this point, so we
2844      call "convert" here to fix that up if necessary. This type consistency is
2845      required, for instance because it ensures that possible later folding of
2846      component_refs against this constructor always yields something of the
2847      same type as the initial reference.
2848
2849      Note that the call to "build_template" above is still fine, because it
2850      will only refer to the provided template_type in this case.  */
2851    return
2852      gnat_build_constructor
2853      (type, tree_cons (TYPE_FIELDS (type),
2854                       convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
2855                       tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
2856                                  template_addr, NULL_TREE)));
2857 }
2858 \f
2859 /* Convert to a thin pointer type, TYPE.  The only thing we know how to convert
2860    is something that is a fat pointer, so convert to it first if it EXPR
2861    is not already a fat pointer.  */
2862
2863 static tree
2864 convert_to_thin_pointer (type, expr)
2865      tree type;
2866      tree expr;
2867 {
2868   if (! TYPE_FAT_POINTER_P (TREE_TYPE (expr)))
2869     expr
2870       = convert_to_fat_pointer
2871         (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr);
2872
2873   /* We get the pointer to the data and use a NOP_EXPR to make it the
2874      proper GCC type.  */
2875   expr
2876     = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)), 0);
2877   expr = build1 (NOP_EXPR, type, expr);
2878
2879   return expr;
2880 }
2881 \f
2882 /* Create an expression whose value is that of EXPR,
2883    converted to type TYPE.  The TREE_TYPE of the value
2884    is always TYPE.  This function implements all reasonable
2885    conversions; callers should filter out those that are
2886    not permitted by the language being compiled.  */
2887
2888 tree
2889 convert (type, expr)
2890      tree type, expr;
2891 {
2892   enum tree_code code = TREE_CODE (type);
2893   tree etype = TREE_TYPE (expr);
2894   enum tree_code ecode = TREE_CODE (etype);
2895   tree tem;
2896
2897   /* If EXPR is already the right type, we are done.  */
2898   if (type == etype)
2899     return expr;
2900   /* If we're converting between two aggregate types that have the same main
2901      variant, just make a NOP_EXPR.  */
2902   else if (AGGREGATE_TYPE_P (type)
2903            && TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
2904     return build1 (NOP_EXPR, type, expr);
2905   /* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
2906      new one.  */
2907   else if (TREE_CODE (expr) == WITH_RECORD_EXPR)
2908     return build (WITH_RECORD_EXPR, type,
2909                   convert (type, TREE_OPERAND (expr, 0)),
2910                   TREE_OPERAND (expr, 1));
2911
2912   /* If the input type has padding, remove it by doing a component reference
2913      to the field.  If the output type has padding, make a constructor
2914      to build the record.  If both input and output have padding and are
2915      of variable size, do this as an unchecked conversion.  */
2916   else if (ecode == RECORD_TYPE && code == RECORD_TYPE
2917       && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
2918       && (! TREE_CONSTANT (TYPE_SIZE (type))
2919           || ! TREE_CONSTANT (TYPE_SIZE (etype))))
2920     ;
2921   else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype))
2922     {
2923       /* If we have just converted to this padded type, just get
2924          the inner expression.  */
2925       if (TREE_CODE (expr) == CONSTRUCTOR
2926           && CONSTRUCTOR_ELTS (expr) != 0
2927           && TREE_PURPOSE (CONSTRUCTOR_ELTS (expr)) == TYPE_FIELDS (etype))
2928         return TREE_VALUE (CONSTRUCTOR_ELTS (expr));
2929       else
2930         return convert (type, build_component_ref (expr, NULL_TREE,
2931                                                    TYPE_FIELDS (etype), 0));
2932     }
2933   else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
2934     {
2935       /* If we previously converted from another type and our type is
2936          of variable size, remove the conversion to avoid the need for
2937          variable-size temporaries.  */
2938       if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
2939           && ! TREE_CONSTANT (TYPE_SIZE (type)))
2940         expr = TREE_OPERAND (expr, 0);
2941
2942       /* If we are just removing the padding from expr, convert the original
2943          object if we have variable size.  That will avoid the need
2944          for some variable-size temporaries.  */
2945       if (TREE_CODE (expr) == COMPONENT_REF
2946           && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE
2947           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
2948           && ! TREE_CONSTANT (TYPE_SIZE (type)))
2949         return convert (type, TREE_OPERAND (expr, 0));
2950
2951       /* If the result type is a padded type with a self-referentially-sized
2952          field and the expression type is a record, do this as an
2953          unchecked converstion.  */
2954       else if (TREE_CODE (etype) == RECORD_TYPE
2955                && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
2956         return unchecked_convert (type, expr, 0);
2957
2958       else
2959         return
2960           gnat_build_constructor (type,
2961                              tree_cons (TYPE_FIELDS (type),
2962                                         convert (TREE_TYPE
2963                                                  (TYPE_FIELDS (type)),
2964                                                  expr),
2965                                         NULL_TREE));
2966     }
2967
2968   /* If the input is a biased type, adjust first.  */
2969   if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
2970     return convert (type, fold (build (PLUS_EXPR, TREE_TYPE (etype),
2971                                        fold (build1 (GNAT_NOP_EXPR,
2972                                                      TREE_TYPE (etype), expr)),
2973                                        TYPE_MIN_VALUE (etype))));
2974
2975   /* If the input is a left-justified modular type, we need to extract
2976      the actual object before converting it to any other type with the
2977      exception of an unconstrained array.  */
2978   if (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)
2979       && code != UNCONSTRAINED_ARRAY_TYPE)
2980     return convert (type, build_component_ref (expr, NULL_TREE,
2981                                                TYPE_FIELDS (etype), 0));
2982
2983   /* If converting to a type that contains a template, convert to the data
2984      type and then build the template. */
2985   if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
2986     {
2987       tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
2988
2989       /* If the source already has a template, get a reference to the
2990          associated array only, as we are going to rebuild a template
2991          for the target type anyway.  */
2992       expr = maybe_unconstrained_array (expr);
2993
2994       return
2995         gnat_build_constructor
2996           (type,
2997            tree_cons (TYPE_FIELDS (type),
2998                       build_template (TREE_TYPE (TYPE_FIELDS (type)),
2999                                       obj_type, NULL_TREE),
3000                       tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
3001                                  convert (obj_type, expr), NULL_TREE)));
3002     }
3003
3004   /* There are some special cases of expressions that we process
3005      specially.  */
3006   switch (TREE_CODE (expr))
3007     {
3008     case ERROR_MARK:
3009       return expr;
3010
3011     case TRANSFORM_EXPR:
3012     case NULL_EXPR:
3013       /* Just set its type here.  For TRANSFORM_EXPR, we will do the actual
3014          conversion in gnat_expand_expr.  NULL_EXPR does not represent
3015          and actual value, so no conversion is needed.  */
3016       expr = copy_node (expr);
3017       TREE_TYPE (expr) = type;
3018       return expr;
3019
3020     case STRING_CST:
3021     case CONSTRUCTOR:
3022       /* If we are converting a STRING_CST to another constrained array type,
3023          just make a new one in the proper type.  Likewise for a
3024          CONSTRUCTOR.  */
3025       if (code == ecode && AGGREGATE_TYPE_P (etype)
3026           && ! (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
3027                 && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
3028         {
3029           expr = copy_node (expr);
3030           TREE_TYPE (expr) = type;
3031           return expr;
3032         }
3033       break;
3034
3035     case COMPONENT_REF:
3036       /* If we are converting between two aggregate types of the same
3037          kind, size, mode, and alignment, just make a new COMPONENT_REF.
3038          This avoid unneeded conversions which makes reference computations
3039          more complex.  */
3040       if (code == ecode && TYPE_MODE (type) == TYPE_MODE (etype)
3041           && AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
3042           && TYPE_ALIGN (type) == TYPE_ALIGN (etype)
3043           && operand_equal_p (TYPE_SIZE (type), TYPE_SIZE (etype), 0))
3044         return build (COMPONENT_REF, type, TREE_OPERAND (expr, 0),
3045                       TREE_OPERAND (expr, 1));
3046
3047       break;
3048
3049     case UNCONSTRAINED_ARRAY_REF:
3050       /* Convert this to the type of the inner array by getting the address of
3051          the array from the template.  */
3052       expr = build_unary_op (INDIRECT_REF, NULL_TREE,
3053                              build_component_ref (TREE_OPERAND (expr, 0),
3054                                                   get_identifier ("P_ARRAY"),
3055                                                   NULL_TREE, 0));
3056       etype = TREE_TYPE (expr);
3057       ecode = TREE_CODE (etype);
3058       break;
3059
3060     case VIEW_CONVERT_EXPR:
3061       if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
3062           && ! TYPE_FAT_POINTER_P (type) && ! TYPE_FAT_POINTER_P (etype))
3063         return convert (type, TREE_OPERAND (expr, 0));
3064       break;
3065
3066     case INDIRECT_REF:
3067       /* If both types are record types, just convert the pointer and
3068          make a new INDIRECT_REF.
3069
3070          ??? Disable this for now since it causes problems with the
3071          code in build_binary_op for MODIFY_EXPR which wants to
3072          strip off conversions.  But that code really is a mess and
3073          we need to do this a much better way some time.  */
3074       if (0
3075           && (TREE_CODE (type) == RECORD_TYPE
3076               || TREE_CODE (type) == UNION_TYPE)
3077           && (TREE_CODE (etype) == RECORD_TYPE
3078               || TREE_CODE (etype) == UNION_TYPE)
3079           && ! TYPE_FAT_POINTER_P (type) && ! TYPE_FAT_POINTER_P (etype))
3080         return build_unary_op (INDIRECT_REF, NULL_TREE,
3081                                convert (build_pointer_type (type),
3082                                         TREE_OPERAND (expr, 0)));
3083       break;
3084
3085     default:
3086       break;
3087     }
3088
3089   /* Check for converting to a pointer to an unconstrained array.  */
3090   if (TYPE_FAT_POINTER_P (type) && ! TYPE_FAT_POINTER_P (etype))
3091     return convert_to_fat_pointer (type, expr);
3092
3093   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
3094       || (code == INTEGER_CST && ecode == INTEGER_CST
3095           && (type == TREE_TYPE (etype) || etype == TREE_TYPE (type))))
3096     return fold (build1 (NOP_EXPR, type, expr));
3097
3098   switch (code)
3099     {
3100     case VOID_TYPE:
3101       return build1 (CONVERT_EXPR, type, expr);
3102
3103     case INTEGER_TYPE:
3104       if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
3105           && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
3106               || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
3107         return unchecked_convert (type, expr, 0);
3108       else if (TYPE_BIASED_REPRESENTATION_P (type))
3109         return fold (build1 (CONVERT_EXPR, type,
3110                              fold (build (MINUS_EXPR, TREE_TYPE (type),
3111                                           convert (TREE_TYPE (type), expr),
3112                                           TYPE_MIN_VALUE (type)))));
3113
3114       /* ... fall through ... */
3115
3116     case ENUMERAL_TYPE:
3117       return fold (convert_to_integer (type, expr));
3118
3119     case POINTER_TYPE:
3120     case REFERENCE_TYPE:
3121       /* If converting between two pointers to records denoting
3122          both a template and type, adjust if needed to account
3123          for any differing offsets, since one might be negative.  */
3124       if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type))
3125         {
3126           tree bit_diff
3127             = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
3128                            bit_position (TYPE_FIELDS (TREE_TYPE (type))));
3129           tree byte_diff = size_binop (CEIL_DIV_EXPR, bit_diff,
3130                                        sbitsize_int (BITS_PER_UNIT));
3131
3132           expr = build1 (NOP_EXPR, type, expr);
3133           TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0));
3134           if (integer_zerop (byte_diff))
3135             return expr;
3136
3137           return build_binary_op (PLUS_EXPR, type, expr,
3138                                   fold (convert_to_pointer (type, byte_diff)));
3139         }
3140
3141       /* If converting to a thin pointer, handle specially.  */
3142       if (TYPE_THIN_POINTER_P (type)
3143           && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)) != 0)
3144         return convert_to_thin_pointer (type, expr);
3145
3146       /* If converting fat pointer to normal pointer, get the pointer to the
3147          array and then convert it.  */
3148       else if (TYPE_FAT_POINTER_P (etype))
3149         expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
3150                                     NULL_TREE, 0);
3151
3152       return fold (convert_to_pointer (type, expr));
3153
3154     case REAL_TYPE:
3155       return fold (convert_to_real (type, expr));
3156
3157     case RECORD_TYPE:
3158       if (TYPE_LEFT_JUSTIFIED_MODULAR_P (type) && ! AGGREGATE_TYPE_P (etype))
3159         return
3160           gnat_build_constructor
3161             (type, tree_cons (TYPE_FIELDS (type),
3162                               convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
3163                               NULL_TREE));
3164
3165       /* ... fall through ... */
3166
3167     case ARRAY_TYPE:
3168       /* In these cases, assume the front-end has validated the conversion.
3169          If the conversion is valid, it will be a bit-wise conversion, so
3170          it can be viewed as an unchecked conversion.  */
3171       return unchecked_convert (type, expr, 0);
3172
3173     case UNION_TYPE:
3174       /* Just validate that the type is indeed that of a field
3175          of the type.  Then make the simple conversion.  */
3176       for (tem = TYPE_FIELDS (type); tem; tem = TREE_CHAIN (tem))
3177         {
3178           if (TREE_TYPE (tem) == etype)
3179             return build1 (CONVERT_EXPR, type, expr);
3180           else if (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
3181                    && (TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
3182                        || TYPE_IS_PADDING_P (TREE_TYPE (tem)))
3183                    && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype)
3184             return build1 (CONVERT_EXPR, type,
3185                            convert (TREE_TYPE (tem), expr));
3186         }
3187
3188       gigi_abort (413);
3189
3190     case UNCONSTRAINED_ARRAY_TYPE:
3191       /* If EXPR is a constrained array, take its address, convert it to a
3192          fat pointer, and then dereference it.  Likewise if EXPR is a
3193          record containing both a template and a constrained array.
3194          Note that a record representing a left justified modular type
3195          always represents a packed constrained array.  */
3196       if (ecode == ARRAY_TYPE
3197           || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
3198           || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
3199           || (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)))
3200         return
3201           build_unary_op
3202             (INDIRECT_REF, NULL_TREE,
3203              convert_to_fat_pointer (TREE_TYPE (type),
3204                                      build_unary_op (ADDR_EXPR,
3205                                                      NULL_TREE, expr)));
3206
3207       /* Do something very similar for converting one unconstrained
3208          array to another.  */
3209       else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
3210         return
3211           build_unary_op (INDIRECT_REF, NULL_TREE,
3212                           convert (TREE_TYPE (type),
3213                                    build_unary_op (ADDR_EXPR,
3214                                                    NULL_TREE, expr)));
3215       else
3216         gigi_abort (409);
3217
3218     case COMPLEX_TYPE:
3219       return fold (convert_to_complex (type, expr));
3220
3221     default:
3222       gigi_abort (410);
3223     }
3224 }
3225 \f
3226 /* Remove all conversions that are done in EXP.  This includes converting
3227    from a padded type or to a left-justified modular type.  If TRUE_ADDRESS
3228    is nonzero, always return the address of the containing object even if
3229    the address is not bit-aligned.  */
3230
3231 tree
3232 remove_conversions (exp, true_address)
3233      tree exp;
3234      int true_address;
3235 {
3236   switch (TREE_CODE (exp))
3237     {
3238     case CONSTRUCTOR:
3239       if (true_address
3240           && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
3241           && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
3242         return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp)), 1);
3243       break;
3244
3245     case COMPONENT_REF:
3246       if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE
3247           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
3248         return remove_conversions (TREE_OPERAND (exp, 0), true_address);
3249       break;
3250
3251     case VIEW_CONVERT_EXPR:  case NON_LVALUE_EXPR:
3252     case NOP_EXPR:  case CONVERT_EXPR:  case GNAT_NOP_EXPR:
3253       return remove_conversions (TREE_OPERAND (exp, 0), true_address);
3254
3255     default:
3256       break;
3257     }
3258
3259   return exp;
3260 }
3261 \f
3262 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
3263    refers to the underlying array.  If its type has TYPE_CONTAINS_TEMPLATE_P,
3264    likewise return an expression pointing to the underlying array.  */
3265
3266 tree
3267 maybe_unconstrained_array (exp)
3268      tree exp;
3269 {
3270   enum tree_code code = TREE_CODE (exp);
3271   tree new;
3272
3273   switch (TREE_CODE (TREE_TYPE (exp)))
3274     {
3275     case UNCONSTRAINED_ARRAY_TYPE:
3276       if (code == UNCONSTRAINED_ARRAY_REF)
3277         {
3278           new
3279             = build_unary_op (INDIRECT_REF, NULL_TREE,
3280                               build_component_ref (TREE_OPERAND (exp, 0),
3281                                                    get_identifier ("P_ARRAY"),
3282                                                    NULL_TREE, 0));
3283           TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
3284           return new;
3285         }
3286
3287       else if (code == NULL_EXPR)
3288         return build1 (NULL_EXPR,
3289                        TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3290                                              (TREE_TYPE (TREE_TYPE (exp))))),
3291                        TREE_OPERAND (exp, 0));
3292
3293       else if (code == WITH_RECORD_EXPR
3294                && (TREE_OPERAND (exp, 0)
3295                    != (new = maybe_unconstrained_array
3296                        (TREE_OPERAND (exp, 0)))))
3297         return build (WITH_RECORD_EXPR, TREE_TYPE (new), new,
3298                       TREE_OPERAND (exp, 1));
3299
3300     case RECORD_TYPE:
3301       /* If this is a padded type, convert to the unpadded type and see if
3302          it contains a template.  */
3303       if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
3304         {
3305           new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
3306           if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
3307               && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
3308             return
3309               build_component_ref (new, NULL_TREE,
3310                                    TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
3311                                    0);
3312         }
3313       else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
3314         return
3315           build_component_ref (exp, NULL_TREE,
3316                                TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0);
3317       break;
3318
3319     default:
3320       break;
3321     }
3322
3323   return exp;
3324 }
3325 \f
3326 /* Return an expression that does an unchecked converstion of EXPR to TYPE.
3327    If NOTRUNC_P is set, truncation operations should be suppressed.  */
3328
3329 tree
3330 unchecked_convert (type, expr, notrunc_p)
3331      tree type;
3332      tree expr;
3333      int notrunc_p;
3334 {
3335   tree etype = TREE_TYPE (expr);
3336
3337   /* If the expression is already the right type, we are done.  */
3338   if (etype == type)
3339     return expr;
3340
3341   /* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
3342      new one.  */
3343   if (TREE_CODE (expr) == WITH_RECORD_EXPR)
3344     return build (WITH_RECORD_EXPR, type,
3345                   unchecked_convert (type, TREE_OPERAND (expr, 0), notrunc_p),
3346                   TREE_OPERAND (expr, 1));
3347
3348   /* If both types types are integral just do a normal conversion.
3349      Likewise for a conversion to an unconstrained array.  */
3350   if ((((INTEGRAL_TYPE_P (type)
3351          && ! (TREE_CODE (type) == INTEGER_TYPE
3352                && TYPE_VAX_FLOATING_POINT_P (type)))
3353         || (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type))
3354         || (TREE_CODE (type) == RECORD_TYPE
3355             && TYPE_LEFT_JUSTIFIED_MODULAR_P (type)))
3356        && ((INTEGRAL_TYPE_P (etype)
3357             && ! (TREE_CODE (etype) == INTEGER_TYPE
3358                   && TYPE_VAX_FLOATING_POINT_P (etype)))
3359            || (POINTER_TYPE_P (etype) && ! TYPE_THIN_POINTER_P (etype))
3360            || (TREE_CODE (etype) == RECORD_TYPE
3361                && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype))))
3362       || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
3363     {
3364       tree rtype = type;
3365
3366       if (TREE_CODE (etype) == INTEGER_TYPE
3367           && TYPE_BIASED_REPRESENTATION_P (etype))
3368         {
3369           tree ntype = copy_type (etype);
3370
3371           TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
3372           TYPE_MAIN_VARIANT (ntype) = ntype;
3373           expr = build1 (GNAT_NOP_EXPR, ntype, expr);
3374         }
3375
3376       if (TREE_CODE (type) == INTEGER_TYPE
3377           && TYPE_BIASED_REPRESENTATION_P (type))
3378         {
3379           rtype = copy_type (type);
3380           TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
3381           TYPE_MAIN_VARIANT (rtype) = rtype;
3382         }
3383
3384       expr = convert (rtype, expr);
3385       if (type != rtype)
3386         expr = build1 (GNAT_NOP_EXPR, type, expr);
3387     }
3388
3389   /* If we are converting TO an integral type whose precision is not the
3390      same as its size, first unchecked convert to a record that contains
3391      an object of the output type.  Then extract the field. */
3392   else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) != 0
3393            && 0 != compare_tree_int (TYPE_RM_SIZE (type),
3394                                      GET_MODE_BITSIZE (TYPE_MODE (type))))
3395     {
3396       tree rec_type = make_node (RECORD_TYPE);
3397       tree field = create_field_decl (get_identifier ("OBJ"), type,
3398                                       rec_type, 1, 0, 0, 0);
3399
3400       TYPE_FIELDS (rec_type) = field;
3401       layout_type (rec_type);
3402
3403       expr = unchecked_convert (rec_type, expr, notrunc_p);
3404       expr = build_component_ref (expr, NULL_TREE, field, 0);
3405     }
3406
3407   /* Similarly for integral input type whose precision is not equal to its
3408      size.  */
3409   else if (INTEGRAL_TYPE_P (etype) && TYPE_RM_SIZE (etype) != 0
3410       && 0 != compare_tree_int (TYPE_RM_SIZE (etype),
3411                                 GET_MODE_BITSIZE (TYPE_MODE (etype))))
3412     {
3413       tree rec_type = make_node (RECORD_TYPE);
3414       tree field
3415         = create_field_decl (get_identifier ("OBJ"), etype, rec_type,
3416                              1, 0, 0, 0);
3417
3418       TYPE_FIELDS (rec_type) = field;
3419       layout_type (rec_type);
3420
3421       expr = gnat_build_constructor (rec_type, build_tree_list (field, expr));
3422       expr = unchecked_convert (type, expr, notrunc_p);
3423     }
3424
3425   /* We have a special case when we are converting between two
3426      unconstrained array types.  In that case, take the address,
3427      convert the fat pointer types, and dereference.  */
3428   else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE
3429            && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
3430     expr = build_unary_op (INDIRECT_REF, NULL_TREE,
3431                            build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
3432                                    build_unary_op (ADDR_EXPR, NULL_TREE,
3433                                                    expr)));
3434   else
3435     {
3436       expr = maybe_unconstrained_array (expr);
3437       etype = TREE_TYPE (expr);
3438       expr = build1 (VIEW_CONVERT_EXPR, type, expr);
3439     }
3440
3441   /* If the result is an integral type whose size is not equal to
3442      the size of the underlying machine type, sign- or zero-extend
3443      the result.  We need not do this in the case where the input is
3444      an integral type of the same precision and signedness or if the output
3445      is a biased type or if both the input and output are unsigned.  */
3446   if (! notrunc_p
3447       && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) != 0
3448       && ! (TREE_CODE (type) == INTEGER_TYPE
3449             && TYPE_BIASED_REPRESENTATION_P (type))
3450       && 0 != compare_tree_int (TYPE_RM_SIZE (type),
3451                                 GET_MODE_BITSIZE (TYPE_MODE (type)))
3452       && ! (INTEGRAL_TYPE_P (etype)
3453             && TREE_UNSIGNED (type) == TREE_UNSIGNED (etype)
3454             && operand_equal_p (TYPE_RM_SIZE (type),
3455                                 (TYPE_RM_SIZE (etype) != 0
3456                                  ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
3457                                 0))
3458       && ! (TREE_UNSIGNED (type) && TREE_UNSIGNED (etype)))
3459     {
3460       tree base_type = gnat_type_for_mode (TYPE_MODE (type),
3461                                            TREE_UNSIGNED (type));
3462       tree shift_expr
3463         = convert (base_type,
3464                    size_binop (MINUS_EXPR,
3465                                bitsize_int
3466                                (GET_MODE_BITSIZE (TYPE_MODE (type))),
3467                                TYPE_RM_SIZE (type)));
3468       expr
3469         = convert (type,
3470                    build_binary_op (RSHIFT_EXPR, base_type,
3471                                     build_binary_op (LSHIFT_EXPR, base_type,
3472                                                      convert (base_type, expr),
3473                                                      shift_expr),
3474                                     shift_expr));
3475     }
3476
3477   /* An unchecked conversion should never raise Constraint_Error.  The code
3478      below assumes that GCC's conversion routines overflow the same way that
3479      the underlying hardware does.  This is probably true.  In the rare case
3480      when it is false, we can rely on the fact that such conversions are
3481      erroneous anyway.  */
3482   if (TREE_CODE (expr) == INTEGER_CST)
3483     TREE_OVERFLOW (expr) = TREE_CONSTANT_OVERFLOW (expr) = 0;
3484
3485   /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
3486      show no longer constant.  */
3487   if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
3488       && ! operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype), 1))
3489     TREE_CONSTANT (expr) = 0;
3490
3491   return expr;
3492 }
3493
3494 #include "gt-ada-utils.h"
3495 #include "gtype-ada.h"