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