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 a 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 a 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   if (TREE_CODE (var_decl) == VAR_DECL)
1286     DECL_COMMON   (var_decl) = !flag_no_common;
1287 #endif
1288   DECL_INITIAL  (var_decl) = var_init;
1289   TREE_READONLY (var_decl) = const_flag;
1290   DECL_EXTERNAL (var_decl) = extern_flag;
1291   TREE_PUBLIC   (var_decl) = public_flag || extern_flag;
1292   TREE_CONSTANT (var_decl) = TREE_CODE (var_decl) == CONST_DECL;
1293   TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
1294     = TYPE_VOLATILE (type);
1295
1296   /* If it's public and not external, always allocate storage for it.
1297      At the global binding level we need to allocate static storage for the
1298      variable if and only if it's not external. If we are not at the top level
1299      we allocate automatic storage unless requested not to.  */
1300   TREE_STATIC (var_decl)
1301     = public_flag || (global_bindings_p () ? !extern_flag : static_flag);
1302
1303   if (asm_name && VAR_OR_FUNCTION_DECL_P (var_decl))
1304     SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
1305
1306   process_attributes (var_decl, attr_list);
1307
1308   /* Add this decl to the current binding level.  */
1309   gnat_pushdecl (var_decl, gnat_node);
1310
1311   if (TREE_SIDE_EFFECTS (var_decl))
1312     TREE_ADDRESSABLE (var_decl) = 1;
1313
1314   if (TREE_CODE (var_decl) != CONST_DECL)
1315     rest_of_decl_compilation (var_decl, global_bindings_p (), 0);
1316
1317   return var_decl;
1318 }
1319 \f
1320 /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
1321    type, and RECORD_TYPE is the type of the parent.  PACKED is nonzero if
1322    this field is in a record type with a "pragma pack".  If SIZE is nonzero
1323    it is the specified size for this field.  If POS is nonzero, it is the bit
1324    position.  If ADDRESSABLE is nonzero, it means we are allowed to take
1325    the address of this field for aliasing purposes. If it is negative, we
1326    should not make a bitfield, which is used by make_aligning_type.   */
1327
1328 tree
1329 create_field_decl (tree field_name, tree field_type, tree record_type,
1330                    int packed, tree size, tree pos, int addressable)
1331 {
1332   tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
1333
1334   DECL_CONTEXT (field_decl) = record_type;
1335   TREE_READONLY (field_decl) = TYPE_READONLY (field_type);
1336
1337   /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1338      byte boundary since GCC cannot handle less-aligned BLKmode bitfields.  */
1339   if (packed && TYPE_MODE (field_type) == BLKmode)
1340     DECL_ALIGN (field_decl) = BITS_PER_UNIT;
1341
1342   /* If a size is specified, use it.  Otherwise, if the record type is packed
1343      compute a size to use, which may differ from the object's natural size.
1344      We always set a size in this case to trigger the checks for bitfield
1345      creation below, which is typically required when no position has been
1346      specified.  */
1347   if (size)
1348     size = convert (bitsizetype, size);
1349   else if (packed == 1)
1350     {
1351       size = rm_size (field_type);
1352
1353       /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
1354          byte.  */
1355       if (TREE_CODE (size) == INTEGER_CST
1356           && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
1357         size = round_up (size, BITS_PER_UNIT);
1358     }
1359
1360   /* If we may, according to ADDRESSABLE, make a bitfield if a size is
1361      specified for two reasons: first if the size differs from the natural
1362      size.  Second, if the alignment is insufficient.  There are a number of
1363      ways the latter can be true.
1364
1365      We never make a bitfield if the type of the field has a nonconstant size,
1366      because no such entity requiring bitfield operations should reach here.
1367
1368      We do *preventively* make a bitfield when there might be the need for it
1369      but we don't have all the necessary information to decide, as is the case
1370      of a field with no specified position in a packed record.
1371
1372      We also don't look at STRICT_ALIGNMENT here, and rely on later processing
1373      in layout_decl or finish_record_type to clear the bit_field indication if
1374      it is in fact not needed.  */
1375   if (addressable >= 0
1376       && size
1377       && TREE_CODE (size) == INTEGER_CST
1378       && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
1379       && (!operand_equal_p (TYPE_SIZE (field_type), size, 0)
1380           || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type)))
1381           || packed
1382           || (TYPE_ALIGN (record_type) != 0
1383               && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
1384     {
1385       DECL_BIT_FIELD (field_decl) = 1;
1386       DECL_SIZE (field_decl) = size;
1387       if (!packed && !pos)
1388         DECL_ALIGN (field_decl)
1389           = (TYPE_ALIGN (record_type) != 0
1390              ? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type))
1391              : TYPE_ALIGN (field_type));
1392     }
1393
1394   DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
1395   DECL_ALIGN (field_decl)
1396     = MAX (DECL_ALIGN (field_decl),
1397            DECL_BIT_FIELD (field_decl) ? 1
1398            : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT
1399            : TYPE_ALIGN (field_type));
1400
1401   if (pos)
1402     {
1403       /* We need to pass in the alignment the DECL is known to have.
1404          This is the lowest-order bit set in POS, but no more than
1405          the alignment of the record, if one is specified.  Note
1406          that an alignment of 0 is taken as infinite.  */
1407       unsigned int known_align;
1408
1409       if (host_integerp (pos, 1))
1410         known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
1411       else
1412         known_align = BITS_PER_UNIT;
1413
1414       if (TYPE_ALIGN (record_type)
1415           && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
1416         known_align = TYPE_ALIGN (record_type);
1417
1418       layout_decl (field_decl, known_align);
1419       SET_DECL_OFFSET_ALIGN (field_decl,
1420                              host_integerp (pos, 1) ? BIGGEST_ALIGNMENT
1421                              : BITS_PER_UNIT);
1422       pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
1423                     &DECL_FIELD_BIT_OFFSET (field_decl),
1424                     DECL_OFFSET_ALIGN (field_decl), pos);
1425
1426       DECL_HAS_REP_P (field_decl) = 1;
1427     }
1428
1429   /* If the field type is passed by reference, we will have pointers to the
1430      field, so it is addressable. */
1431   if (must_pass_by_ref (field_type) || default_pass_by_ref (field_type))
1432     addressable = 1;
1433
1434   /* ??? For now, we say that any field of aggregate type is addressable
1435      because the front end may take 'Reference of it.  */
1436   if (AGGREGATE_TYPE_P (field_type))
1437     addressable = 1;
1438
1439   /* Mark the decl as nonaddressable if it is indicated so semantically,
1440      meaning we won't ever attempt to take the address of the field.
1441
1442      It may also be "technically" nonaddressable, meaning that even if we
1443      attempt to take the field's address we will actually get the address of a
1444      copy. This is the case for true bitfields, but the DECL_BIT_FIELD value
1445      we have at this point is not accurate enough, so we don't account for
1446      this here and let finish_record_type decide.  */
1447   DECL_NONADDRESSABLE_P (field_decl) = !addressable;
1448
1449   return field_decl;
1450 }
1451
1452 /* Subroutine of previous function: return nonzero if EXP, ignoring any side
1453    effects, has the value of zero.  */
1454
1455 static bool
1456 value_zerop (tree exp)
1457 {
1458   if (TREE_CODE (exp) == COMPOUND_EXPR)
1459     return value_zerop (TREE_OPERAND (exp, 1));
1460
1461   return integer_zerop (exp);
1462 }
1463 \f
1464 /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
1465    PARAM_TYPE is its type.  READONLY is true if the parameter is
1466    readonly (either an IN parameter or an address of a pass-by-ref
1467    parameter). */
1468
1469 tree
1470 create_param_decl (tree param_name, tree param_type, bool readonly)
1471 {
1472   tree param_decl = build_decl (PARM_DECL, param_name, param_type);
1473
1474   /* Honor targetm.calls.promote_prototypes(), as not doing so can
1475      lead to various ABI violations.  */
1476   if (targetm.calls.promote_prototypes (param_type)
1477       && (TREE_CODE (param_type) == INTEGER_TYPE
1478           || TREE_CODE (param_type) == ENUMERAL_TYPE)
1479       && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
1480     {
1481       /* We have to be careful about biased types here.  Make a subtype
1482          of integer_type_node with the proper biasing.  */
1483       if (TREE_CODE (param_type) == INTEGER_TYPE
1484           && TYPE_BIASED_REPRESENTATION_P (param_type))
1485         {
1486           param_type
1487             = copy_type (build_range_type (integer_type_node,
1488                                            TYPE_MIN_VALUE (param_type),
1489                                            TYPE_MAX_VALUE (param_type)));
1490
1491           TYPE_BIASED_REPRESENTATION_P (param_type) = 1;
1492         }
1493       else
1494         param_type = integer_type_node;
1495     }
1496
1497   DECL_ARG_TYPE (param_decl) = param_type;
1498   TREE_READONLY (param_decl) = readonly;
1499   return param_decl;
1500 }
1501 \f
1502 /* Given a DECL and ATTR_LIST, process the listed attributes.  */
1503
1504 void
1505 process_attributes (tree decl, struct attrib *attr_list)
1506 {
1507   for (; attr_list; attr_list = attr_list->next)
1508     switch (attr_list->type)
1509       {
1510       case ATTR_MACHINE_ATTRIBUTE:
1511         decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
1512                                            NULL_TREE),
1513                          ATTR_FLAG_TYPE_IN_PLACE);
1514         break;
1515
1516       case ATTR_LINK_ALIAS:
1517         if (! DECL_EXTERNAL (decl))
1518           {
1519             TREE_STATIC (decl) = 1;
1520             assemble_alias (decl, attr_list->name);
1521           }
1522         break;
1523
1524       case ATTR_WEAK_EXTERNAL:
1525         if (SUPPORTS_WEAK)
1526           declare_weak (decl);
1527         else
1528           post_error ("?weak declarations not supported on this target",
1529                       attr_list->error_point);
1530         break;
1531
1532       case ATTR_LINK_SECTION:
1533         if (targetm.have_named_sections)
1534           {
1535             DECL_SECTION_NAME (decl)
1536               = build_string (IDENTIFIER_LENGTH (attr_list->name),
1537                               IDENTIFIER_POINTER (attr_list->name));
1538             DECL_COMMON (decl) = 0;
1539           }
1540         else
1541           post_error ("?section attributes are not supported for this target",
1542                       attr_list->error_point);
1543         break;
1544
1545       case ATTR_LINK_CONSTRUCTOR:
1546         DECL_STATIC_CONSTRUCTOR (decl) = 1;
1547         TREE_USED (decl) = 1;
1548         break;
1549
1550       case ATTR_LINK_DESTRUCTOR:
1551         DECL_STATIC_DESTRUCTOR (decl) = 1;
1552         TREE_USED (decl) = 1;
1553         break;
1554       }
1555 }
1556 \f
1557 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
1558    a power of 2. */
1559
1560 static bool
1561 value_factor_p (tree value, HOST_WIDE_INT factor)
1562 {
1563   if (host_integerp (value, 1))
1564     return tree_low_cst (value, 1) % factor == 0;
1565
1566   if (TREE_CODE (value) == MULT_EXPR)
1567     return (value_factor_p (TREE_OPERAND (value, 0), factor)
1568             || value_factor_p (TREE_OPERAND (value, 1), factor));
1569
1570   return 0;
1571 }
1572
1573 /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
1574    unless we can prove these 2 fields are laid out in such a way that no gap
1575    exist between the end of PREV_FIELD and the beginning of CURR_FIELD.  OFFSET
1576    is the distance in bits between the end of PREV_FIELD and the starting
1577    position of CURR_FIELD. It is ignored if null. */
1578
1579 static bool
1580 potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
1581 {
1582   /* If this is the first field of the record, there cannot be any gap */
1583   if (!prev_field)
1584     return false;
1585
1586   /* If the previous field is a union type, then return False: The only
1587      time when such a field is not the last field of the record is when
1588      there are other components at fixed positions after it (meaning there
1589      was a rep clause for every field), in which case we don't want the
1590      alignment constraint to override them. */
1591   if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
1592     return false;
1593
1594   /* If the distance between the end of prev_field and the beginning of
1595      curr_field is constant, then there is a gap if the value of this
1596      constant is not null. */
1597   if (offset && host_integerp (offset, 1))
1598     return !integer_zerop (offset);
1599
1600   /* If the size and position of the previous field are constant,
1601      then check the sum of this size and position. There will be a gap
1602      iff it is not multiple of the current field alignment. */
1603   if (host_integerp (DECL_SIZE (prev_field), 1)
1604       && host_integerp (bit_position (prev_field), 1))
1605     return ((tree_low_cst (bit_position (prev_field), 1)
1606              + tree_low_cst (DECL_SIZE (prev_field), 1))
1607             % DECL_ALIGN (curr_field) != 0);
1608
1609   /* If both the position and size of the previous field are multiples
1610      of the current field alignment, there can not be any gap. */
1611   if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
1612       && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
1613     return false;
1614
1615   /* Fallback, return that there may be a potential gap */
1616   return true;
1617 }
1618
1619 /* Returns a LABEL_DECL node for LABEL_NAME.  */
1620
1621 tree
1622 create_label_decl (tree label_name)
1623 {
1624   tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node);
1625
1626   DECL_CONTEXT (label_decl)     = current_function_decl;
1627   DECL_MODE (label_decl)        = VOIDmode;
1628   DECL_SOURCE_LOCATION (label_decl) = input_location;
1629
1630   return label_decl;
1631 }
1632 \f
1633 /* Returns a FUNCTION_DECL node.  SUBPROG_NAME is the name of the subprogram,
1634    ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1635    node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1636    PARM_DECL nodes chained through the TREE_CHAIN field).
1637
1638    INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
1639    appropriate fields in the FUNCTION_DECL.  GNAT_NODE gives the location.  */
1640
1641 tree
1642 create_subprog_decl (tree subprog_name, tree asm_name,
1643                      tree subprog_type, tree param_decl_list, bool inline_flag,
1644                      bool public_flag, bool extern_flag,
1645                      struct attrib *attr_list, Node_Id gnat_node)
1646 {
1647   tree return_type  = TREE_TYPE (subprog_type);
1648   tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
1649
1650   /* If this is a function nested inside an inlined external function, it
1651      means we aren't going to compile the outer function unless it is
1652      actually inlined, so do the same for us.  */
1653   if (current_function_decl && DECL_INLINE (current_function_decl)
1654       && DECL_EXTERNAL (current_function_decl))
1655     extern_flag = true;
1656
1657   DECL_EXTERNAL (subprog_decl)  = extern_flag;
1658   TREE_PUBLIC (subprog_decl)    = public_flag;
1659   TREE_STATIC (subprog_decl)    = 1;
1660   TREE_READONLY (subprog_decl)  = TYPE_READONLY (subprog_type);
1661   TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
1662   TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
1663   DECL_ARGUMENTS (subprog_decl) = param_decl_list;
1664   DECL_RESULT (subprog_decl)    = build_decl (RESULT_DECL, 0, return_type);
1665   DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1;
1666   DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1;
1667
1668   if (inline_flag)
1669     DECL_DECLARED_INLINE_P (subprog_decl) = 1;
1670
1671   if (asm_name)
1672     SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
1673
1674   process_attributes (subprog_decl, attr_list);
1675
1676   /* Add this decl to the current binding level.  */
1677   gnat_pushdecl (subprog_decl, gnat_node);
1678
1679   /* Output the assembler code and/or RTL for the declaration.  */
1680   rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
1681
1682   return subprog_decl;
1683 }
1684 \f
1685 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1686    body. This routine needs to be invoked before processing the declarations
1687    appearing in the subprogram.  */
1688
1689 void
1690 begin_subprog_body (tree subprog_decl)
1691 {
1692   tree param_decl;
1693
1694   current_function_decl = subprog_decl;
1695   announce_function (subprog_decl);
1696
1697   /* Enter a new binding level and show that all the parameters belong to
1698      this function.  */
1699   gnat_pushlevel ();
1700   for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
1701        param_decl = TREE_CHAIN (param_decl))
1702     DECL_CONTEXT (param_decl) = subprog_decl;
1703
1704   make_decl_rtl (subprog_decl);
1705
1706   /* We handle pending sizes via the elaboration of types, so we don't need to
1707      save them.  This causes them to be marked as part of the outer function
1708      and then discarded.  */
1709   get_pending_sizes ();
1710 }
1711
1712 /* Finish the definition of the current subprogram and compile it all the way
1713    to assembler language output.  BODY is the tree corresponding to
1714    the subprogram.  */
1715
1716 void
1717 end_subprog_body (tree body)
1718 {
1719   tree fndecl = current_function_decl;
1720
1721   /* Mark the BLOCK for this level as being for this function and pop the
1722      level.  Since the vars in it are the parameters, clear them.  */
1723   BLOCK_VARS (current_binding_level->block) = 0;
1724   BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
1725   DECL_INITIAL (fndecl) = current_binding_level->block;
1726   gnat_poplevel ();
1727
1728   /* Deal with inline.  If declared inline or we should default to inline,
1729      set the flag in the decl.  */
1730   DECL_INLINE (fndecl)
1731     = DECL_DECLARED_INLINE_P (fndecl) || flag_inline_trees == 2;
1732
1733   /* We handle pending sizes via the elaboration of types, so we don't
1734      need to save them.  */
1735   get_pending_sizes ();
1736
1737   /* Mark the RESULT_DECL as being in this subprogram. */
1738   DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
1739
1740   DECL_SAVED_TREE (fndecl) = body;
1741
1742   current_function_decl = DECL_CONTEXT (fndecl);
1743   cfun = NULL;
1744
1745   /* If we're only annotating types, don't actually compile this function.  */
1746   if (type_annotate_only)
1747     return;
1748
1749   /* If we don't have .ctors/.dtors sections, and this is a static
1750      constructor or destructor, it must be recorded now.  */
1751   if (DECL_STATIC_CONSTRUCTOR (fndecl) && !targetm.have_ctors_dtors)
1752     static_ctors = tree_cons (NULL_TREE, fndecl, static_ctors);
1753
1754   if (DECL_STATIC_DESTRUCTOR (fndecl) && !targetm.have_ctors_dtors)
1755     static_dtors = tree_cons (NULL_TREE, fndecl, static_dtors);
1756
1757   /* We do different things for nested and non-nested functions.
1758      ??? This should be in cgraph.  */
1759   if (!DECL_CONTEXT (fndecl))
1760     {
1761       gnat_gimplify_function (fndecl);
1762       cgraph_finalize_function (fndecl, false);
1763     }
1764   else
1765     /* Register this function with cgraph just far enough to get it
1766        added to our parent's nested function list.  */
1767     (void) cgraph_node (fndecl);
1768 }
1769
1770 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1771
1772 static void
1773 gnat_gimplify_function (tree fndecl)
1774 {
1775   struct cgraph_node *cgn;
1776
1777   dump_function (TDI_original, fndecl);
1778   gimplify_function_tree (fndecl);
1779   dump_function (TDI_generic, fndecl);
1780
1781   /* Convert all nested functions to GIMPLE now.  We do things in this order
1782      so that items like VLA sizes are expanded properly in the context of the
1783      correct function.  */
1784   cgn = cgraph_node (fndecl);
1785   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1786     gnat_gimplify_function (cgn->decl);
1787 }
1788 \f
1789 /* Return a definition for a builtin function named NAME and whose data type
1790    is TYPE.  TYPE should be a function type with argument types.
1791    FUNCTION_CODE tells later passes how to compile calls to this function.
1792    See tree.h for its possible values.
1793
1794    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
1795    the name to be called if we can't opencode the function.  If
1796    ATTRS is nonzero, use that for the function attribute list.  */
1797
1798 tree
1799 builtin_function (const char *name, tree type, int function_code,
1800                   enum built_in_class class, const char *library_name,
1801                   tree attrs)
1802 {
1803   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
1804
1805   DECL_EXTERNAL (decl) = 1;
1806   TREE_PUBLIC (decl) = 1;
1807   if (library_name)
1808     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
1809
1810   gnat_pushdecl (decl, Empty);
1811   DECL_BUILT_IN_CLASS (decl) = class;
1812   DECL_FUNCTION_CODE (decl) = function_code;
1813   if (attrs)
1814       decl_attributes (&decl, attrs, ATTR_FLAG_BUILT_IN);
1815   return decl;
1816 }
1817
1818 /* Return an integer type with the number of bits of precision given by
1819    PRECISION.  UNSIGNEDP is nonzero if the type is unsigned; otherwise
1820    it is a signed type.  */
1821
1822 tree
1823 gnat_type_for_size (unsigned precision, int unsignedp)
1824 {
1825   tree t;
1826   char type_name[20];
1827
1828   if (precision <= 2 * MAX_BITS_PER_WORD
1829       && signed_and_unsigned_types[precision][unsignedp])
1830     return signed_and_unsigned_types[precision][unsignedp];
1831
1832  if (unsignedp)
1833     t = make_unsigned_type (precision);
1834   else
1835     t = make_signed_type (precision);
1836
1837   if (precision <= 2 * MAX_BITS_PER_WORD)
1838     signed_and_unsigned_types[precision][unsignedp] = t;
1839
1840   if (!TYPE_NAME (t))
1841     {
1842       sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
1843       TYPE_NAME (t) = get_identifier (type_name);
1844     }
1845
1846   return t;
1847 }
1848
1849 /* Likewise for floating-point types.  */
1850
1851 static tree
1852 float_type_for_precision (int precision, enum machine_mode mode)
1853 {
1854   tree t;
1855   char type_name[20];
1856
1857   if (float_types[(int) mode])
1858     return float_types[(int) mode];
1859
1860   float_types[(int) mode] = t = make_node (REAL_TYPE);
1861   TYPE_PRECISION (t) = precision;
1862   layout_type (t);
1863
1864   gcc_assert (TYPE_MODE (t) == mode);
1865   if (!TYPE_NAME (t))
1866     {
1867       sprintf (type_name, "FLOAT_%d", precision);
1868       TYPE_NAME (t) = get_identifier (type_name);
1869     }
1870
1871   return t;
1872 }
1873
1874 /* Return a data type that has machine mode MODE.  UNSIGNEDP selects
1875    an unsigned type; otherwise a signed type is returned.  */
1876
1877 tree
1878 gnat_type_for_mode (enum machine_mode mode, int unsignedp)
1879 {
1880   if (mode == BLKmode)
1881     return NULL_TREE;
1882   else if (mode == VOIDmode)
1883     return void_type_node;
1884   else if (COMPLEX_MODE_P (mode))
1885     return NULL_TREE;
1886   else if (SCALAR_FLOAT_MODE_P (mode))
1887     return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
1888   else if (SCALAR_INT_MODE_P (mode))
1889     return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
1890   else
1891     return NULL_TREE;
1892 }
1893
1894 /* Return the unsigned version of a TYPE_NODE, a scalar type.  */
1895
1896 tree
1897 gnat_unsigned_type (tree type_node)
1898 {
1899   tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
1900
1901   if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
1902     {
1903       type = copy_node (type);
1904       TREE_TYPE (type) = type_node;
1905     }
1906   else if (TREE_TYPE (type_node)
1907            && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
1908            && TYPE_MODULAR_P (TREE_TYPE (type_node)))
1909     {
1910       type = copy_node (type);
1911       TREE_TYPE (type) = TREE_TYPE (type_node);
1912     }
1913
1914   return type;
1915 }
1916
1917 /* Return the signed version of a TYPE_NODE, a scalar type.  */
1918
1919 tree
1920 gnat_signed_type (tree type_node)
1921 {
1922   tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
1923
1924   if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
1925     {
1926       type = copy_node (type);
1927       TREE_TYPE (type) = type_node;
1928     }
1929   else if (TREE_TYPE (type_node)
1930            && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
1931            && TYPE_MODULAR_P (TREE_TYPE (type_node)))
1932     {
1933       type = copy_node (type);
1934       TREE_TYPE (type) = TREE_TYPE (type_node);
1935     }
1936
1937   return type;
1938 }
1939
1940 /* Return a type the same as TYPE except unsigned or signed according to
1941    UNSIGNEDP.  */
1942
1943 tree
1944 gnat_signed_or_unsigned_type (int unsignedp, tree type)
1945 {
1946   if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
1947     return type;
1948   else
1949     return gnat_type_for_size (TYPE_PRECISION (type), unsignedp);
1950 }
1951 \f
1952 /* EXP is an expression for the size of an object.  If this size contains
1953    discriminant references, replace them with the maximum (if MAX_P) or
1954    minimum (if !MAX_P) possible value of the discriminant.  */
1955
1956 tree
1957 max_size (tree exp, bool max_p)
1958 {
1959   enum tree_code code = TREE_CODE (exp);
1960   tree type = TREE_TYPE (exp);
1961
1962   switch (TREE_CODE_CLASS (code))
1963     {
1964     case tcc_declaration:
1965     case tcc_constant:
1966       return exp;
1967
1968     case tcc_exceptional:
1969       if (code == TREE_LIST)
1970         return tree_cons (TREE_PURPOSE (exp),
1971                           max_size (TREE_VALUE (exp), max_p),
1972                           TREE_CHAIN (exp)
1973                           ? max_size (TREE_CHAIN (exp), max_p) : NULL_TREE);
1974       break;
1975
1976     case tcc_reference:
1977       /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
1978          modify.  Otherwise, we treat it like a variable.  */
1979       if (!CONTAINS_PLACEHOLDER_P (exp))
1980         return exp;
1981
1982       type = TREE_TYPE (TREE_OPERAND (exp, 1));
1983       return
1984         max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true);
1985
1986     case tcc_comparison:
1987       return max_p ? size_one_node : size_zero_node;
1988
1989     case tcc_unary:
1990     case tcc_binary:
1991     case tcc_expression:
1992       switch (TREE_CODE_LENGTH (code))
1993         {
1994         case 1:
1995           if (code == NON_LVALUE_EXPR)
1996             return max_size (TREE_OPERAND (exp, 0), max_p);
1997           else
1998             return
1999               fold (build1 (code, type,
2000                             max_size (TREE_OPERAND (exp, 0),
2001                                       code == NEGATE_EXPR ? !max_p : max_p)));
2002
2003         case 2:
2004           if (code == COMPOUND_EXPR)
2005             return max_size (TREE_OPERAND (exp, 1), max_p);
2006
2007           {
2008             tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
2009             tree rhs = max_size (TREE_OPERAND (exp, 1),
2010                                  code == MINUS_EXPR ? !max_p : max_p);
2011
2012             /* Special-case wanting the maximum value of a MIN_EXPR.
2013                In that case, if one side overflows, return the other.
2014                sizetype is signed, but we know sizes are non-negative.
2015                Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2016                overflowing or the maximum possible value and the RHS
2017                a variable.  */
2018             if (max_p && code == MIN_EXPR && TREE_OVERFLOW (rhs))
2019               return lhs;
2020             else if (max_p && code == MIN_EXPR && TREE_OVERFLOW (lhs))
2021               return rhs;
2022             else if ((code == MINUS_EXPR || code == PLUS_EXPR)
2023                      && ((TREE_CONSTANT (lhs) && TREE_OVERFLOW (lhs))
2024                          || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
2025                      && !TREE_CONSTANT (rhs))
2026               return lhs;
2027             else
2028               return fold (build2 (code, type, lhs, rhs));
2029           }
2030
2031         case 3:
2032           if (code == SAVE_EXPR)
2033             return exp;
2034           else if (code == COND_EXPR)
2035             return fold (build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
2036                                  max_size (TREE_OPERAND (exp, 1), max_p),
2037                                  max_size (TREE_OPERAND (exp, 2), max_p)));
2038           else if (code == CALL_EXPR && TREE_OPERAND (exp, 1))
2039             return build3 (CALL_EXPR, type, TREE_OPERAND (exp, 0),
2040                            max_size (TREE_OPERAND (exp, 1), max_p), NULL);
2041         }
2042
2043       /* Other tree classes cannot happen.  */
2044     default:
2045       break;
2046     }
2047
2048   gcc_unreachable ();
2049 }
2050 \f
2051 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2052    EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2053    Return a constructor for the template.  */
2054
2055 tree
2056 build_template (tree template_type, tree array_type, tree expr)
2057 {
2058   tree template_elts = NULL_TREE;
2059   tree bound_list = NULL_TREE;
2060   tree field;
2061
2062   if (TREE_CODE (array_type) == RECORD_TYPE
2063       && (TYPE_IS_PADDING_P (array_type)
2064           || TYPE_JUSTIFIED_MODULAR_P (array_type)))
2065     array_type = TREE_TYPE (TYPE_FIELDS (array_type));
2066
2067   if (TREE_CODE (array_type) == ARRAY_TYPE
2068       || (TREE_CODE (array_type) == INTEGER_TYPE
2069           && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
2070     bound_list = TYPE_ACTUAL_BOUNDS (array_type);
2071
2072   /* First make the list for a CONSTRUCTOR for the template.   Go down the
2073      field list of the template instead of the type chain because this
2074      array might be an Ada array of arrays and we can't tell where the
2075      nested arrays stop being the underlying object.  */
2076
2077   for (field = TYPE_FIELDS (template_type); field;
2078        (bound_list
2079         ? (bound_list = TREE_CHAIN (bound_list))
2080         : (array_type = TREE_TYPE (array_type))),
2081        field = TREE_CHAIN (TREE_CHAIN (field)))
2082     {
2083       tree bounds, min, max;
2084
2085       /* If we have a bound list, get the bounds from there.  Likewise
2086          for an ARRAY_TYPE.  Otherwise, if expr is a PARM_DECL with
2087          DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2088          This will give us a maximum range.  */
2089       if (bound_list)
2090         bounds = TREE_VALUE (bound_list);
2091       else if (TREE_CODE (array_type) == ARRAY_TYPE)
2092         bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
2093       else if (expr && TREE_CODE (expr) == PARM_DECL
2094                && DECL_BY_COMPONENT_PTR_P (expr))
2095         bounds = TREE_TYPE (field);
2096       else
2097         gcc_unreachable ();
2098
2099       min = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MIN_VALUE (bounds));
2100       max = convert (TREE_TYPE (field), TYPE_MAX_VALUE (bounds));
2101
2102       /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2103          substitute it from OBJECT.  */
2104       min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
2105       max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
2106
2107       template_elts = tree_cons (TREE_CHAIN (field), max,
2108                                  tree_cons (field, min, template_elts));
2109     }
2110
2111   return gnat_build_constructor (template_type, nreverse (template_elts));
2112 }
2113 \f
2114 /* Build a VMS descriptor from a Mechanism_Type, which must specify
2115    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
2116    in the type contains in its DECL_INITIAL the expression to use when
2117    a constructor is made for the type.  GNAT_ENTITY is an entity used
2118    to print out an error message if the mechanism cannot be applied to
2119    an object of that type and also for the name.  */
2120
2121 tree
2122 build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2123 {
2124   tree record_type = make_node (RECORD_TYPE);
2125   tree field_list = 0;
2126   int class;
2127   int dtype = 0;
2128   tree inner_type;
2129   int ndim;
2130   int i;
2131   tree *idx_arr;
2132   tree tem;
2133
2134   /* If TYPE is an unconstrained array, use the underlying array type.  */
2135   if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2136     type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2137
2138   /* If this is an array, compute the number of dimensions in the array,
2139      get the index types, and point to the inner type.  */
2140   if (TREE_CODE (type) != ARRAY_TYPE)
2141     ndim = 0;
2142   else
2143     for (ndim = 1, inner_type = type;
2144          TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2145          && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2146          ndim++, inner_type = TREE_TYPE (inner_type))
2147       ;
2148
2149   idx_arr = (tree *) alloca (ndim * sizeof (tree));
2150
2151   if (mech != By_Descriptor_NCA
2152       && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2153     for (i = ndim - 1, inner_type = type;
2154          i >= 0;
2155          i--, inner_type = TREE_TYPE (inner_type))
2156       idx_arr[i] = TYPE_DOMAIN (inner_type);
2157   else
2158     for (i = 0, inner_type = type;
2159          i < ndim;
2160          i++, inner_type = TREE_TYPE (inner_type))
2161       idx_arr[i] = TYPE_DOMAIN (inner_type);
2162
2163   /* Now get the DTYPE value.  */
2164   switch (TREE_CODE (type))
2165     {
2166     case INTEGER_TYPE:
2167     case ENUMERAL_TYPE:
2168       if (TYPE_VAX_FLOATING_POINT_P (type))
2169         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2170           {
2171           case 6:
2172             dtype = 10;
2173             break;
2174           case 9:
2175             dtype = 11;
2176             break;
2177           case 15:
2178             dtype = 27;
2179             break;
2180           }
2181       else
2182         switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2183           {
2184           case 8:
2185             dtype = TYPE_UNSIGNED (type) ? 2 : 6;
2186             break;
2187           case 16:
2188             dtype = TYPE_UNSIGNED (type) ? 3 : 7;
2189             break;
2190           case 32:
2191             dtype = TYPE_UNSIGNED (type) ? 4 : 8;
2192             break;
2193           case 64:
2194             dtype = TYPE_UNSIGNED (type) ? 5 : 9;
2195             break;
2196           case 128:
2197             dtype = TYPE_UNSIGNED (type) ? 25 : 26;
2198             break;
2199           }
2200       break;
2201
2202     case REAL_TYPE:
2203       dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2204       break;
2205
2206     case COMPLEX_TYPE:
2207       if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2208           && TYPE_VAX_FLOATING_POINT_P (type))
2209         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2210           {
2211           case 6:
2212             dtype = 12;
2213             break;
2214           case 9:
2215             dtype = 13;
2216             break;
2217           case 15:
2218             dtype = 29;
2219           }
2220       else
2221         dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2222       break;
2223
2224     case ARRAY_TYPE:
2225       dtype = 14;
2226       break;
2227
2228     default:
2229       break;
2230     }
2231
2232   /* Get the CLASS value.  */
2233   switch (mech)
2234     {
2235     case By_Descriptor_A:
2236       class = 4;
2237       break;
2238     case By_Descriptor_NCA:
2239       class = 10;
2240       break;
2241     case By_Descriptor_SB:
2242       class = 15;
2243       break;
2244     default:
2245       class = 1;
2246     }
2247
2248   /* Make the type for a descriptor for VMS.  The first four fields
2249      are the same for all types.  */
2250
2251   field_list
2252     = chainon (field_list,
2253                make_descriptor_field
2254                ("LENGTH", gnat_type_for_size (16, 1), record_type,
2255                 size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
2256
2257   field_list = chainon (field_list,
2258                         make_descriptor_field ("DTYPE",
2259                                                gnat_type_for_size (8, 1),
2260                                                record_type, size_int (dtype)));
2261   field_list = chainon (field_list,
2262                         make_descriptor_field ("CLASS",
2263                                                gnat_type_for_size (8, 1),
2264                                                record_type, size_int (class)));
2265
2266   field_list
2267     = chainon (field_list,
2268                make_descriptor_field
2269                ("POINTER",
2270                 build_pointer_type_for_mode (type, SImode, false), record_type,
2271                 build1 (ADDR_EXPR,
2272                         build_pointer_type_for_mode (type, SImode, false),
2273                         build0 (PLACEHOLDER_EXPR, type))));
2274
2275   switch (mech)
2276     {
2277     case By_Descriptor:
2278     case By_Descriptor_S:
2279       break;
2280
2281     case By_Descriptor_SB:
2282       field_list
2283         = chainon (field_list,
2284                    make_descriptor_field
2285                    ("SB_L1", gnat_type_for_size (32, 1), record_type,
2286                     TREE_CODE (type) == ARRAY_TYPE
2287                     ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
2288       field_list
2289         = chainon (field_list,
2290                    make_descriptor_field
2291                    ("SB_L2", gnat_type_for_size (32, 1), record_type,
2292                     TREE_CODE (type) == ARRAY_TYPE
2293                     ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
2294       break;
2295
2296     case By_Descriptor_A:
2297     case By_Descriptor_NCA:
2298       field_list = chainon (field_list,
2299                             make_descriptor_field ("SCALE",
2300                                                    gnat_type_for_size (8, 1),
2301                                                    record_type,
2302                                                    size_zero_node));
2303
2304       field_list = chainon (field_list,
2305                             make_descriptor_field ("DIGITS",
2306                                                    gnat_type_for_size (8, 1),
2307                                                    record_type,
2308                                                    size_zero_node));
2309
2310       field_list
2311         = chainon (field_list,
2312                    make_descriptor_field
2313                    ("AFLAGS", gnat_type_for_size (8, 1), record_type,
2314                     size_int (mech == By_Descriptor_NCA
2315                               ? 0
2316                               /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS.  */
2317                               : (TREE_CODE (type) == ARRAY_TYPE
2318                                  && TYPE_CONVENTION_FORTRAN_P (type)
2319                                  ? 224 : 192))));
2320
2321       field_list = chainon (field_list,
2322                             make_descriptor_field ("DIMCT",
2323                                                    gnat_type_for_size (8, 1),
2324                                                    record_type,
2325                                                    size_int (ndim)));
2326
2327       field_list = chainon (field_list,
2328                             make_descriptor_field ("ARSIZE",
2329                                                    gnat_type_for_size (32, 1),
2330                                                    record_type,
2331                                                    size_in_bytes (type)));
2332
2333       /* Now build a pointer to the 0,0,0... element.  */
2334       tem = build0 (PLACEHOLDER_EXPR, type);
2335       for (i = 0, inner_type = type; i < ndim;
2336            i++, inner_type = TREE_TYPE (inner_type))
2337         tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
2338                       convert (TYPE_DOMAIN (inner_type), size_zero_node),
2339                       NULL_TREE, NULL_TREE);
2340
2341       field_list
2342         = chainon (field_list,
2343                    make_descriptor_field
2344                    ("A0",
2345                     build_pointer_type_for_mode (inner_type, SImode, false),
2346                     record_type,
2347                     build1 (ADDR_EXPR,
2348                             build_pointer_type_for_mode (inner_type, SImode,
2349                                                          false),
2350                             tem)));
2351
2352       /* Next come the addressing coefficients.  */
2353       tem = size_int (1);
2354       for (i = 0; i < ndim; i++)
2355         {
2356           char fname[3];
2357           tree idx_length
2358             = size_binop (MULT_EXPR, tem,
2359                           size_binop (PLUS_EXPR,
2360                                       size_binop (MINUS_EXPR,
2361                                                   TYPE_MAX_VALUE (idx_arr[i]),
2362                                                   TYPE_MIN_VALUE (idx_arr[i])),
2363                                       size_int (1)));
2364
2365           fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
2366           fname[1] = '0' + i, fname[2] = 0;
2367           field_list
2368             = chainon (field_list,
2369                        make_descriptor_field (fname,
2370                                               gnat_type_for_size (32, 1),
2371                                               record_type, idx_length));
2372
2373           if (mech == By_Descriptor_NCA)
2374             tem = idx_length;
2375         }
2376
2377       /* Finally here are the bounds.  */
2378       for (i = 0; i < ndim; i++)
2379         {
2380           char fname[3];
2381
2382           fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
2383           field_list
2384             = chainon (field_list,
2385                        make_descriptor_field
2386                        (fname, gnat_type_for_size (32, 1), record_type,
2387                         TYPE_MIN_VALUE (idx_arr[i])));
2388
2389           fname[0] = 'U';
2390           field_list
2391             = chainon (field_list,
2392                        make_descriptor_field
2393                        (fname, gnat_type_for_size (32, 1), record_type,
2394                         TYPE_MAX_VALUE (idx_arr[i])));
2395         }
2396       break;
2397
2398     default:
2399       post_error ("unsupported descriptor type for &", gnat_entity);
2400     }
2401
2402   finish_record_type (record_type, field_list, false, true);
2403   create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type,
2404                     NULL, true, false, gnat_entity);
2405
2406   return record_type;
2407 }
2408
2409 /* Utility routine for above code to make a field.  */
2410
2411 static tree
2412 make_descriptor_field (const char *name, tree type,
2413                        tree rec_type, tree initial)
2414 {
2415   tree field
2416     = create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
2417
2418   DECL_INITIAL (field) = initial;
2419   return field;
2420 }
2421 \f
2422 /* Build a type to be used to represent an aliased object whose nominal
2423    type is an unconstrained array.  This consists of a RECORD_TYPE containing
2424    a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
2425    ARRAY_TYPE.  If ARRAY_TYPE is that of the unconstrained array, this
2426    is used to represent an arbitrary unconstrained object.  Use NAME
2427    as the name of the record.  */
2428
2429 tree
2430 build_unc_object_type (tree template_type, tree object_type, tree name)
2431 {
2432   tree type = make_node (RECORD_TYPE);
2433   tree template_field = create_field_decl (get_identifier ("BOUNDS"),
2434                                            template_type, type, 0, 0, 0, 1);
2435   tree array_field = create_field_decl (get_identifier ("ARRAY"), object_type,
2436                                         type, 0, 0, 0, 1);
2437
2438   TYPE_NAME (type) = name;
2439   TYPE_CONTAINS_TEMPLATE_P (type) = 1;
2440   finish_record_type (type,
2441                       chainon (chainon (NULL_TREE, template_field),
2442                                array_field),
2443                       false, false);
2444
2445   return type;
2446 }
2447 \f
2448 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.  In
2449    the normal case this is just two adjustments, but we have more to do
2450    if NEW is an UNCONSTRAINED_ARRAY_TYPE.  */
2451
2452 void
2453 update_pointer_to (tree old_type, tree new_type)
2454 {
2455   tree ptr = TYPE_POINTER_TO (old_type);
2456   tree ref = TYPE_REFERENCE_TO (old_type);
2457   tree ptr1, ref1;
2458   tree type;
2459
2460   /* If this is the main variant, process all the other variants first.  */
2461   if (TYPE_MAIN_VARIANT (old_type) == old_type)
2462     for (type = TYPE_NEXT_VARIANT (old_type); type;
2463          type = TYPE_NEXT_VARIANT (type))
2464       update_pointer_to (type, new_type);
2465
2466   /* If no pointer or reference, we are done.  */
2467   if (!ptr && !ref)
2468     return;
2469
2470   /* Merge the old type qualifiers in the new type.
2471
2472      Each old variant has qualifiers for specific reasons, and the new
2473      designated type as well. Each set of qualifiers represents useful
2474      information grabbed at some point, and merging the two simply unifies
2475      these inputs into the final type description.
2476
2477      Consider for instance a volatile type frozen after an access to constant
2478      type designating it. After the designated type freeze, we get here with a
2479      volatile new_type and a dummy old_type with a readonly variant, created
2480      when the access type was processed. We shall make a volatile and readonly
2481      designated type, because that's what it really is.
2482
2483      We might also get here for a non-dummy old_type variant with different
2484      qualifiers than the new_type ones, for instance in some cases of pointers
2485      to private record type elaboration (see the comments around the call to
2486      this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the
2487      qualifiers in thoses cases too, to avoid accidentally discarding the
2488      initial set, and will often end up with old_type == new_type then.  */
2489   new_type = build_qualified_type (new_type,
2490                                    TYPE_QUALS (old_type)
2491                                    | TYPE_QUALS (new_type));
2492
2493   /* If the new type and the old one are identical, there is nothing to
2494      update.  */
2495   if (old_type == new_type)
2496     return;
2497
2498   /* Otherwise, first handle the simple case.  */
2499   if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
2500     {
2501       TYPE_POINTER_TO (new_type) = ptr;
2502       TYPE_REFERENCE_TO (new_type) = ref;
2503
2504       for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
2505         for (ptr1 = TYPE_MAIN_VARIANT (ptr); ptr1;
2506              ptr1 = TYPE_NEXT_VARIANT (ptr1))
2507           TREE_TYPE (ptr1) = new_type;
2508
2509       for (; ref; ref = TYPE_NEXT_REF_TO (ref))
2510         for (ref1 = TYPE_MAIN_VARIANT (ref); ref1;
2511              ref1 = TYPE_NEXT_VARIANT (ref1))
2512           TREE_TYPE (ref1) = new_type;
2513     }
2514
2515   /* Now deal with the unconstrained array case. In this case the "pointer"
2516      is actually a RECORD_TYPE where the types of both fields are
2517      pointers to void.  In that case, copy the field list from the
2518      old type to the new one and update the fields' context. */
2519   else if (TREE_CODE (ptr) != RECORD_TYPE || !TYPE_IS_FAT_POINTER_P (ptr))
2520     gcc_unreachable ();
2521
2522   else
2523     {
2524       tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type);
2525       tree ptr_temp_type;
2526       tree new_ref;
2527       tree var;
2528
2529       SET_DECL_ORIGINAL_FIELD (TYPE_FIELDS (ptr),
2530                                TYPE_FIELDS (TYPE_POINTER_TO (new_type)));
2531       SET_DECL_ORIGINAL_FIELD (TREE_CHAIN (TYPE_FIELDS (ptr)),
2532                                TREE_CHAIN (TYPE_FIELDS
2533                                            (TYPE_POINTER_TO (new_type))));
2534
2535       TYPE_FIELDS (ptr) = TYPE_FIELDS (TYPE_POINTER_TO (new_type));
2536       DECL_CONTEXT (TYPE_FIELDS (ptr)) = ptr;
2537       DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr))) = ptr;
2538
2539       /* Rework the PLACEHOLDER_EXPR inside the reference to the
2540          template bounds.
2541
2542          ??? This is now the only use of gnat_substitute_in_type, which
2543          is now a very "heavy" routine to do this, so it should be replaced
2544          at some point.  */
2545       ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr)));
2546       new_ref = build3 (COMPONENT_REF, ptr_temp_type,
2547                         build0 (PLACEHOLDER_EXPR, ptr),
2548                         TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE);
2549
2550       update_pointer_to
2551         (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
2552          gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
2553                                   TREE_CHAIN (TYPE_FIELDS (ptr)), new_ref));
2554
2555       for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var))
2556         SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type);
2557
2558       TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type)
2559         = TREE_TYPE (new_type) = ptr;
2560
2561       /* Now handle updating the allocation record, what the thin pointer
2562          points to.  Update all pointers from the old record into the new
2563          one, update the types of the fields, and recompute the size.  */
2564
2565       update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec);
2566
2567       TREE_TYPE (TYPE_FIELDS (new_obj_rec)) = TREE_TYPE (ptr_temp_type);
2568       TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
2569         = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr)));
2570       DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
2571         = TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
2572       DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
2573         = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
2574
2575       TYPE_SIZE (new_obj_rec)
2576         = size_binop (PLUS_EXPR,
2577                       DECL_SIZE (TYPE_FIELDS (new_obj_rec)),
2578                       DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
2579       TYPE_SIZE_UNIT (new_obj_rec)
2580         = size_binop (PLUS_EXPR,
2581                       DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec)),
2582                       DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
2583       rest_of_type_compilation (ptr, global_bindings_p ());
2584     }
2585 }
2586 \f
2587 /* Convert a pointer to a constrained array into a pointer to a fat
2588    pointer.  This involves making or finding a template.  */
2589
2590 static tree
2591 convert_to_fat_pointer (tree type, tree expr)
2592 {
2593   tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))));
2594   tree template, template_addr;
2595   tree etype = TREE_TYPE (expr);
2596
2597   /* If EXPR is a constant of zero, we make a fat pointer that has a null
2598      pointer to the template and array.  */
2599   if (integer_zerop (expr))
2600     return
2601       gnat_build_constructor
2602         (type,
2603          tree_cons (TYPE_FIELDS (type),
2604                     convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
2605                     tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
2606                                convert (build_pointer_type (template_type),
2607                                         expr),
2608                                NULL_TREE)));
2609
2610   /* If EXPR is a thin pointer, make the template and data from the record.  */
2611
2612   else if (TYPE_THIN_POINTER_P (etype))
2613     {
2614       tree fields = TYPE_FIELDS (TREE_TYPE (etype));
2615
2616       expr = save_expr (expr);
2617       if (TREE_CODE (expr) == ADDR_EXPR)
2618         expr = TREE_OPERAND (expr, 0);
2619       else
2620         expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
2621
2622       template = build_component_ref (expr, NULL_TREE, fields, false);
2623       expr = build_unary_op (ADDR_EXPR, NULL_TREE,
2624                              build_component_ref (expr, NULL_TREE,
2625                                                   TREE_CHAIN (fields), false));
2626     }
2627   else
2628     /* Otherwise, build the constructor for the template.  */
2629     template = build_template (template_type, TREE_TYPE (etype), expr);
2630
2631   template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
2632
2633   /* The result is a CONSTRUCTOR for the fat pointer.
2634
2635      If expr is an argument of a foreign convention subprogram, the type it
2636      points to is directly the component type. In this case, the expression
2637      type may not match the corresponding FIELD_DECL type at this point, so we
2638      call "convert" here to fix that up if necessary. This type consistency is
2639      required, for instance because it ensures that possible later folding of
2640      component_refs against this constructor always yields something of the
2641      same type as the initial reference.
2642
2643      Note that the call to "build_template" above is still fine, because it
2644      will only refer to the provided template_type in this case.  */
2645    return
2646      gnat_build_constructor
2647      (type, tree_cons (TYPE_FIELDS (type),
2648                       convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
2649                       tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
2650                                  template_addr, NULL_TREE)));
2651 }
2652 \f
2653 /* Convert to a thin pointer type, TYPE.  The only thing we know how to convert
2654    is something that is a fat pointer, so convert to it first if it EXPR
2655    is not already a fat pointer.  */
2656
2657 static tree
2658 convert_to_thin_pointer (tree type, tree expr)
2659 {
2660   if (!TYPE_FAT_POINTER_P (TREE_TYPE (expr)))
2661     expr
2662       = convert_to_fat_pointer
2663         (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr);
2664
2665   /* We get the pointer to the data and use a NOP_EXPR to make it the
2666      proper GCC type.  */
2667   expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)),
2668                               false);
2669   expr = build1 (NOP_EXPR, type, expr);
2670
2671   return expr;
2672 }
2673 \f
2674 /* Create an expression whose value is that of EXPR,
2675    converted to type TYPE.  The TREE_TYPE of the value
2676    is always TYPE.  This function implements all reasonable
2677    conversions; callers should filter out those that are
2678    not permitted by the language being compiled.  */
2679
2680 tree
2681 convert (tree type, tree expr)
2682 {
2683   enum tree_code code = TREE_CODE (type);
2684   tree etype = TREE_TYPE (expr);
2685   enum tree_code ecode = TREE_CODE (etype);
2686   tree tem;
2687
2688   /* If EXPR is already the right type, we are done.  */
2689   if (type == etype)
2690     return expr;
2691
2692   /* If the input type has padding, remove it by doing a component reference
2693      to the field.  If the output type has padding, make a constructor
2694      to build the record.  If both input and output have padding and are
2695      of variable size, do this as an unchecked conversion.  */
2696   else if (ecode == RECORD_TYPE && code == RECORD_TYPE
2697       && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
2698       && (!TREE_CONSTANT (TYPE_SIZE (type))
2699           || !TREE_CONSTANT (TYPE_SIZE (etype))))
2700     ;
2701   else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype))
2702     {
2703       /* If we have just converted to this padded type, just get
2704          the inner expression.  */
2705       if (TREE_CODE (expr) == CONSTRUCTOR
2706           && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr))
2707           && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index
2708              == TYPE_FIELDS (etype))
2709         return VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value;
2710       else
2711         return convert (type,
2712                         build_component_ref (expr, NULL_TREE,
2713                                              TYPE_FIELDS (etype), false));
2714     }
2715   else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
2716     {
2717       /* If we previously converted from another type and our type is
2718          of variable size, remove the conversion to avoid the need for
2719          variable-size temporaries.  */
2720       if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
2721           && !TREE_CONSTANT (TYPE_SIZE (type)))
2722         expr = TREE_OPERAND (expr, 0);
2723
2724       /* If we are just removing the padding from expr, convert the original
2725          object if we have variable size.  That will avoid the need
2726          for some variable-size temporaries.  */
2727       if (TREE_CODE (expr) == COMPONENT_REF
2728           && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE
2729           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
2730           && !TREE_CONSTANT (TYPE_SIZE (type)))
2731         return convert (type, TREE_OPERAND (expr, 0));
2732
2733       /* If the result type is a padded type with a self-referentially-sized
2734          field and the expression type is a record, do this as an
2735          unchecked conversion.  */
2736       else if (TREE_CODE (etype) == RECORD_TYPE
2737                && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
2738         return unchecked_convert (type, expr, false);
2739
2740       else
2741         return
2742           gnat_build_constructor (type,
2743                              tree_cons (TYPE_FIELDS (type),
2744                                         convert (TREE_TYPE
2745                                                  (TYPE_FIELDS (type)),
2746                                                  expr),
2747                                         NULL_TREE));
2748     }
2749
2750   /* If the input is a biased type, adjust first.  */
2751   if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
2752     return convert (type, fold (build2 (PLUS_EXPR, TREE_TYPE (etype),
2753                                         fold (build1 (NOP_EXPR,
2754                                                       TREE_TYPE (etype),
2755                                                       expr)),
2756                                         TYPE_MIN_VALUE (etype))));
2757
2758   /* If the input is a justified modular type, we need to extract
2759      the actual object before converting it to any other type with the
2760      exception of an unconstrained array.  */
2761   if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
2762       && code != UNCONSTRAINED_ARRAY_TYPE)
2763     return convert (type, build_component_ref (expr, NULL_TREE,
2764                                                TYPE_FIELDS (etype), false));
2765
2766   /* If converting to a type that contains a template, convert to the data
2767      type and then build the template. */
2768   if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
2769     {
2770       tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
2771
2772       /* If the source already has a template, get a reference to the
2773          associated array only, as we are going to rebuild a template
2774          for the target type anyway.  */
2775       expr = maybe_unconstrained_array (expr);
2776
2777       return
2778         gnat_build_constructor
2779           (type,
2780            tree_cons (TYPE_FIELDS (type),
2781                       build_template (TREE_TYPE (TYPE_FIELDS (type)),
2782                                       obj_type, NULL_TREE),
2783                       tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
2784                                  convert (obj_type, expr), NULL_TREE)));
2785     }
2786
2787   /* There are some special cases of expressions that we process
2788      specially.  */
2789   switch (TREE_CODE (expr))
2790     {
2791     case ERROR_MARK:
2792       return expr;
2793
2794     case NULL_EXPR:
2795       /* Just set its type here.  For TRANSFORM_EXPR, we will do the actual
2796          conversion in gnat_expand_expr.  NULL_EXPR does not represent
2797          and actual value, so no conversion is needed.  */
2798       expr = copy_node (expr);
2799       TREE_TYPE (expr) = type;
2800       return expr;
2801
2802     case STRING_CST:
2803       /* If we are converting a STRING_CST to another constrained array type,
2804          just make a new one in the proper type.  */
2805       if (code == ecode && AGGREGATE_TYPE_P (etype)
2806           && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
2807                && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2808           && (TREE_CODE (expr) == STRING_CST
2809               || get_alias_set (etype) == get_alias_set (type)))
2810         {
2811           expr = copy_node (expr);
2812           TREE_TYPE (expr) = type;
2813           return expr;
2814         }
2815       break;
2816
2817     case UNCONSTRAINED_ARRAY_REF:
2818       /* Convert this to the type of the inner array by getting the address of
2819          the array from the template.  */
2820       expr = build_unary_op (INDIRECT_REF, NULL_TREE,
2821                              build_component_ref (TREE_OPERAND (expr, 0),
2822                                                   get_identifier ("P_ARRAY"),
2823                                                   NULL_TREE, false));
2824       etype = TREE_TYPE (expr);
2825       ecode = TREE_CODE (etype);
2826       break;
2827
2828     case VIEW_CONVERT_EXPR:
2829       if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
2830           && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
2831         return convert (type, TREE_OPERAND (expr, 0));
2832       break;
2833
2834     case INDIRECT_REF:
2835       /* If both types are record types, just convert the pointer and
2836          make a new INDIRECT_REF.
2837
2838          ??? Disable this for now since it causes problems with the
2839          code in build_binary_op for MODIFY_EXPR which wants to
2840          strip off conversions.  But that code really is a mess and
2841          we need to do this a much better way some time.  */
2842       if (0
2843           && (TREE_CODE (type) == RECORD_TYPE
2844               || TREE_CODE (type) == UNION_TYPE)
2845           && (TREE_CODE (etype) == RECORD_TYPE
2846               || TREE_CODE (etype) == UNION_TYPE)
2847           && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
2848         return build_unary_op (INDIRECT_REF, NULL_TREE,
2849                                convert (build_pointer_type (type),
2850                                         TREE_OPERAND (expr, 0)));
2851       break;
2852
2853     default:
2854       break;
2855     }
2856
2857   /* Check for converting to a pointer to an unconstrained array.  */
2858   if (TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
2859     return convert_to_fat_pointer (type, expr);
2860
2861   /* If we're converting between two aggregate types that have the same main
2862      variant, just make a VIEW_CONVER_EXPR.  */
2863   else if (AGGREGATE_TYPE_P (type)
2864            && TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
2865     return build1 (VIEW_CONVERT_EXPR, type, expr);
2866
2867   /* In all other cases of related types, make a NOP_EXPR.  */
2868   else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
2869            || (code == INTEGER_CST && ecode == INTEGER_CST
2870                && (type == TREE_TYPE (etype) || etype == TREE_TYPE (type))))
2871     return fold (build1 (NOP_EXPR, type, expr));
2872
2873   switch (code)
2874     {
2875     case VOID_TYPE:
2876       return build1 (CONVERT_EXPR, type, expr);
2877
2878     case BOOLEAN_TYPE:
2879       return fold (build1 (NOP_EXPR, type, gnat_truthvalue_conversion (expr)));
2880
2881     case INTEGER_TYPE:
2882       if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
2883           && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
2884               || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
2885         return unchecked_convert (type, expr, false);
2886       else if (TYPE_BIASED_REPRESENTATION_P (type))
2887         return fold (build1 (CONVERT_EXPR, type,
2888                              fold (build2 (MINUS_EXPR, TREE_TYPE (type),
2889                                            convert (TREE_TYPE (type), expr),
2890                                            TYPE_MIN_VALUE (type)))));
2891
2892       /* ... fall through ... */
2893
2894     case ENUMERAL_TYPE:
2895       return fold (convert_to_integer (type, expr));
2896
2897     case POINTER_TYPE:
2898     case REFERENCE_TYPE:
2899       /* If converting between two pointers to records denoting
2900          both a template and type, adjust if needed to account
2901          for any differing offsets, since one might be negative.  */
2902       if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type))
2903         {
2904           tree bit_diff
2905             = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
2906                            bit_position (TYPE_FIELDS (TREE_TYPE (type))));
2907           tree byte_diff = size_binop (CEIL_DIV_EXPR, bit_diff,
2908                                        sbitsize_int (BITS_PER_UNIT));
2909
2910           expr = build1 (NOP_EXPR, type, expr);
2911           TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0));
2912           if (integer_zerop (byte_diff))
2913             return expr;
2914
2915           return build_binary_op (PLUS_EXPR, type, expr,
2916                                   fold (convert_to_pointer (type, byte_diff)));
2917         }
2918
2919       /* If converting to a thin pointer, handle specially.  */
2920       if (TYPE_THIN_POINTER_P (type)
2921           && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
2922         return convert_to_thin_pointer (type, expr);
2923
2924       /* If converting fat pointer to normal pointer, get the pointer to the
2925          array and then convert it.  */
2926       else if (TYPE_FAT_POINTER_P (etype))
2927         expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
2928                                     NULL_TREE, false);
2929
2930       return fold (convert_to_pointer (type, expr));
2931
2932     case REAL_TYPE:
2933       return fold (convert_to_real (type, expr));
2934
2935     case RECORD_TYPE:
2936       if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype))
2937         return
2938           gnat_build_constructor
2939             (type, tree_cons (TYPE_FIELDS (type),
2940                               convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
2941                               NULL_TREE));
2942
2943       /* ... fall through ... */
2944
2945     case ARRAY_TYPE:
2946       /* In these cases, assume the front-end has validated the conversion.
2947          If the conversion is valid, it will be a bit-wise conversion, so
2948          it can be viewed as an unchecked conversion.  */
2949       return unchecked_convert (type, expr, false);
2950
2951     case UNION_TYPE:
2952       /* For unchecked unions, just validate that the type is indeed that of
2953          a field of the type.  Then make the simple conversion.  */
2954       if (TYPE_UNCHECKED_UNION_P (type))
2955         {
2956           for (tem = TYPE_FIELDS (type); tem; tem = TREE_CHAIN (tem))
2957             {
2958               if (TREE_TYPE (tem) == etype)
2959                 return build1 (CONVERT_EXPR, type, expr);
2960
2961               /* Accept slight type variations.  */
2962               if (TREE_TYPE (tem) == TYPE_MAIN_VARIANT (etype)
2963                   || (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
2964                       && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
2965                           || TYPE_IS_PADDING_P (TREE_TYPE (tem)))
2966                       && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype))
2967                 return build1 (CONVERT_EXPR, type,
2968                                convert (TREE_TYPE (tem), expr));
2969             }
2970
2971           gcc_unreachable ();
2972         }
2973       else
2974         /* Otherwise, this is a conversion between a tagged type and some
2975            subtype, which we have to mark as a UNION_TYPE because of
2976            overlapping fields.  */
2977         return unchecked_convert (type, expr, false);
2978
2979     case UNCONSTRAINED_ARRAY_TYPE:
2980       /* If EXPR is a constrained array, take its address, convert it to a
2981          fat pointer, and then dereference it.  Likewise if EXPR is a
2982          record containing both a template and a constrained array.
2983          Note that a record representing a justified modular type
2984          always represents a packed constrained array.  */
2985       if (ecode == ARRAY_TYPE
2986           || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
2987           || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
2988           || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))
2989         return
2990           build_unary_op
2991             (INDIRECT_REF, NULL_TREE,
2992              convert_to_fat_pointer (TREE_TYPE (type),
2993                                      build_unary_op (ADDR_EXPR,
2994                                                      NULL_TREE, expr)));
2995
2996       /* Do something very similar for converting one unconstrained
2997          array to another.  */
2998       else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
2999         return
3000           build_unary_op (INDIRECT_REF, NULL_TREE,
3001                           convert (TREE_TYPE (type),
3002                                    build_unary_op (ADDR_EXPR,
3003                                                    NULL_TREE, expr)));
3004       else
3005         gcc_unreachable ();
3006
3007     case COMPLEX_TYPE:
3008       return fold (convert_to_complex (type, expr));
3009
3010     default:
3011       gcc_unreachable ();
3012     }
3013 }
3014 \f
3015 /* Remove all conversions that are done in EXP.  This includes converting
3016    from a padded type or to a justified modular type.  If TRUE_ADDRESS
3017    is true, always return the address of the containing object even if
3018    the address is not bit-aligned.  */
3019
3020 tree
3021 remove_conversions (tree exp, bool true_address)
3022 {
3023   switch (TREE_CODE (exp))
3024     {
3025     case CONSTRUCTOR:
3026       if (true_address
3027           && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
3028           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
3029         return remove_conversions (VEC_index (constructor_elt,
3030                                               CONSTRUCTOR_ELTS (exp), 0)->value,
3031                                    true);
3032       break;
3033
3034     case COMPONENT_REF:
3035       if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE
3036           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
3037         return remove_conversions (TREE_OPERAND (exp, 0), true_address);
3038       break;
3039
3040     case VIEW_CONVERT_EXPR:  case NON_LVALUE_EXPR:
3041     case NOP_EXPR:  case CONVERT_EXPR:
3042       return remove_conversions (TREE_OPERAND (exp, 0), true_address);
3043
3044     default:
3045       break;
3046     }
3047
3048   return exp;
3049 }
3050 \f
3051 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
3052    refers to the underlying array.  If its type has TYPE_CONTAINS_TEMPLATE_P,
3053    likewise return an expression pointing to the underlying array.  */
3054
3055 tree
3056 maybe_unconstrained_array (tree exp)
3057 {
3058   enum tree_code code = TREE_CODE (exp);
3059   tree new;
3060
3061   switch (TREE_CODE (TREE_TYPE (exp)))
3062     {
3063     case UNCONSTRAINED_ARRAY_TYPE:
3064       if (code == UNCONSTRAINED_ARRAY_REF)
3065         {
3066           new
3067             = build_unary_op (INDIRECT_REF, NULL_TREE,
3068                               build_component_ref (TREE_OPERAND (exp, 0),
3069                                                    get_identifier ("P_ARRAY"),
3070                                                    NULL_TREE, false));
3071           TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
3072           return new;
3073         }
3074
3075       else if (code == NULL_EXPR)
3076         return build1 (NULL_EXPR,
3077                        TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3078                                              (TREE_TYPE (TREE_TYPE (exp))))),
3079                        TREE_OPERAND (exp, 0));
3080
3081     case RECORD_TYPE:
3082       /* If this is a padded type, convert to the unpadded type and see if
3083          it contains a template.  */
3084       if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
3085         {
3086           new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
3087           if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
3088               && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
3089             return
3090               build_component_ref (new, NULL_TREE,
3091                                    TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
3092                                    0);
3093         }
3094       else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
3095         return
3096           build_component_ref (exp, NULL_TREE,
3097                                TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0);
3098       break;
3099
3100     default:
3101       break;
3102     }
3103
3104   return exp;
3105 }
3106 \f
3107 /* Return an expression that does an unchecked conversion of EXPR to TYPE.
3108    If NOTRUNC_P is true, truncation operations should be suppressed.  */
3109
3110 tree
3111 unchecked_convert (tree type, tree expr, bool notrunc_p)
3112 {
3113   tree etype = TREE_TYPE (expr);
3114
3115   /* If the expression is already the right type, we are done.  */
3116   if (etype == type)
3117     return expr;
3118
3119   /* If both types types are integral just do a normal conversion.
3120      Likewise for a conversion to an unconstrained array.  */
3121   if ((((INTEGRAL_TYPE_P (type)
3122          && !(TREE_CODE (type) == INTEGER_TYPE
3123               && TYPE_VAX_FLOATING_POINT_P (type)))
3124         || (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type))
3125         || (TREE_CODE (type) == RECORD_TYPE
3126             && TYPE_JUSTIFIED_MODULAR_P (type)))
3127        && ((INTEGRAL_TYPE_P (etype)
3128             && !(TREE_CODE (etype) == INTEGER_TYPE
3129                  && TYPE_VAX_FLOATING_POINT_P (etype)))
3130            || (POINTER_TYPE_P (etype) && !TYPE_THIN_POINTER_P (etype))
3131            || (TREE_CODE (etype) == RECORD_TYPE
3132                && TYPE_JUSTIFIED_MODULAR_P (etype))))
3133       || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
3134     {
3135       tree rtype = type;
3136
3137       if (TREE_CODE (etype) == INTEGER_TYPE
3138           && TYPE_BIASED_REPRESENTATION_P (etype))
3139         {
3140           tree ntype = copy_type (etype);
3141
3142           TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
3143           TYPE_MAIN_VARIANT (ntype) = ntype;
3144           expr = build1 (NOP_EXPR, ntype, expr);
3145         }
3146
3147       if (TREE_CODE (type) == INTEGER_TYPE
3148           && TYPE_BIASED_REPRESENTATION_P (type))
3149         {
3150           rtype = copy_type (type);
3151           TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
3152           TYPE_MAIN_VARIANT (rtype) = rtype;
3153         }
3154
3155       expr = convert (rtype, expr);
3156       if (type != rtype)
3157         expr = build1 (NOP_EXPR, type, expr);
3158     }
3159
3160   /* If we are converting TO an integral type whose precision is not the
3161      same as its size, first unchecked convert to a record that contains
3162      an object of the output type.  Then extract the field. */
3163   else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
3164            && 0 != compare_tree_int (TYPE_RM_SIZE (type),
3165                                      GET_MODE_BITSIZE (TYPE_MODE (type))))
3166     {
3167       tree rec_type = make_node (RECORD_TYPE);
3168       tree field = create_field_decl (get_identifier ("OBJ"), type,
3169                                       rec_type, 1, 0, 0, 0);
3170
3171       TYPE_FIELDS (rec_type) = field;
3172       layout_type (rec_type);
3173
3174       expr = unchecked_convert (rec_type, expr, notrunc_p);
3175       expr = build_component_ref (expr, NULL_TREE, field, 0);
3176     }
3177
3178   /* Similarly for integral input type whose precision is not equal to its
3179      size.  */
3180   else if (INTEGRAL_TYPE_P (etype) && TYPE_RM_SIZE (etype)
3181       && 0 != compare_tree_int (TYPE_RM_SIZE (etype),
3182                                 GET_MODE_BITSIZE (TYPE_MODE (etype))))
3183     {
3184       tree rec_type = make_node (RECORD_TYPE);
3185       tree field
3186         = create_field_decl (get_identifier ("OBJ"), etype, rec_type,
3187                              1, 0, 0, 0);
3188
3189       TYPE_FIELDS (rec_type) = field;
3190       layout_type (rec_type);
3191
3192       expr = gnat_build_constructor (rec_type, build_tree_list (field, expr));
3193       expr = unchecked_convert (type, expr, notrunc_p);
3194     }
3195
3196   /* We have a special case when we are converting between two
3197      unconstrained array types.  In that case, take the address,
3198      convert the fat pointer types, and dereference.  */
3199   else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE
3200            && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
3201     expr = build_unary_op (INDIRECT_REF, NULL_TREE,
3202                            build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
3203                                    build_unary_op (ADDR_EXPR, NULL_TREE,
3204                                                    expr)));
3205   else
3206     {
3207       expr = maybe_unconstrained_array (expr);
3208
3209       /* There's no point in doing two unchecked conversions in a row.  */
3210       if (TREE_CODE (expr) == VIEW_CONVERT_EXPR)
3211         expr = TREE_OPERAND (expr, 0);
3212
3213       etype = TREE_TYPE (expr);
3214       expr = build1 (VIEW_CONVERT_EXPR, type, expr);
3215     }
3216
3217   /* If the result is an integral type whose size is not equal to
3218      the size of the underlying machine type, sign- or zero-extend
3219      the result.  We need not do this in the case where the input is
3220      an integral type of the same precision and signedness or if the output
3221      is a biased type or if both the input and output are unsigned.  */
3222   if (!notrunc_p
3223       && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
3224       && !(TREE_CODE (type) == INTEGER_TYPE
3225            && TYPE_BIASED_REPRESENTATION_P (type))
3226       && 0 != compare_tree_int (TYPE_RM_SIZE (type),
3227                                 GET_MODE_BITSIZE (TYPE_MODE (type)))
3228       && !(INTEGRAL_TYPE_P (etype)
3229            && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype)
3230            && operand_equal_p (TYPE_RM_SIZE (type),
3231                                (TYPE_RM_SIZE (etype) != 0
3232                                 ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
3233                                0))
3234       && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype)))
3235     {
3236       tree base_type = gnat_type_for_mode (TYPE_MODE (type),
3237                                            TYPE_UNSIGNED (type));
3238       tree shift_expr
3239         = convert (base_type,
3240                    size_binop (MINUS_EXPR,
3241                                bitsize_int
3242                                (GET_MODE_BITSIZE (TYPE_MODE (type))),
3243                                TYPE_RM_SIZE (type)));
3244       expr
3245         = convert (type,
3246                    build_binary_op (RSHIFT_EXPR, base_type,
3247                                     build_binary_op (LSHIFT_EXPR, base_type,
3248                                                      convert (base_type, expr),
3249                                                      shift_expr),
3250                                     shift_expr));
3251     }
3252
3253   /* An unchecked conversion should never raise Constraint_Error.  The code
3254      below assumes that GCC's conversion routines overflow the same way that
3255      the underlying hardware does.  This is probably true.  In the rare case
3256      when it is false, we can rely on the fact that such conversions are
3257      erroneous anyway.  */
3258   if (TREE_CODE (expr) == INTEGER_CST)
3259     TREE_OVERFLOW (expr) = TREE_CONSTANT_OVERFLOW (expr) = 0;
3260
3261   /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
3262      show no longer constant.  */
3263   if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
3264       && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype),
3265                            OEP_ONLY_CONST))
3266     TREE_CONSTANT (expr) = 0;
3267
3268   return expr;
3269 }
3270 \f
3271 /* Search the chain of currently reachable declarations for a builtin
3272    FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE).
3273    Return the first node found, if any, or NULL_TREE otherwise.  */
3274
3275 tree
3276 builtin_decl_for (tree name __attribute__ ((unused)))
3277 {
3278   /* ??? not clear yet how to implement this function in tree-ssa, so
3279      return NULL_TREE for now */
3280   return NULL_TREE;
3281 }
3282
3283 #include "gt-ada-utils.h"
3284 #include "gtype-ada.h"