gcc/ada/utils.c

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