gcc/ada/utils.c

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