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