gcc/ada/gcc-interface/trans.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                T R A N S                                 *
   6  *                                                                          *
   7  *                          C Implementation File                           *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2011, Free Software Foundation, Inc.         *
  10  *                                                                          *
  11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  12  * terms of the  GNU General Public License as published  by the Free Soft- *
  13  * ware  Foundation;  either version 3,  or (at your option) any later ver- *
  14  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  15  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  16  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  17  * for  more details.  You should have  received  a copy of the GNU General *
  18  * Public License  distributed  with GNAT;  see file  COPYING3.  If not see *
  19  * <http://www.gnu.org/licenses/>.                                          *
  20  *                                                                          *
  21  * GNAT was originally developed  by the GNAT team at  New York University. *
  22  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  23  *                                                                          *
  24  ****************************************************************************/
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "tm.h"
  30 #include "tree.h"
  31 #include "flags.h"
  32 #include "ggc.h"
  33 #include "output.h"
  34 #include "libfuncs.h"   /* For set_stack_check_libfunc.  */
  35 #include "tree-iterator.h"
  36 #include "gimple.h"
  37
  38 #include "ada.h"
  39 #include "adadecode.h"
  40 #include "types.h"
  41 #include "atree.h"
  42 #include "elists.h"
  43 #include "namet.h"
  44 #include "nlists.h"
  45 #include "snames.h"
  46 #include "stringt.h"
  47 #include "uintp.h"
  48 #include "urealp.h"
  49 #include "fe.h"
  50 #include "sinfo.h"
  51 #include "einfo.h"
  52 #include "gadaint.h"
  53 #include "ada-tree.h"
  54 #include "gigi.h"
  55
  56 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
  57    for fear of running out of stack space.  If we need more, we use xmalloc
  58    instead.  */
  59 #define ALLOCA_THRESHOLD 1000
  60
  61 /* Let code below know whether we are targetting VMS without need of
  62    intrusive preprocessor directives.  */
  63 #ifndef TARGET_ABI_OPEN_VMS
  64 #define TARGET_ABI_OPEN_VMS 0
  65 #endif
  66
  67 /* In configurations where blocks have no end_locus attached, just
  68    sink assignments into a dummy global.  */
  69 #ifndef BLOCK_SOURCE_END_LOCATION
  70 static location_t block_end_locus_sink;
  71 #define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink
  72 #endif
  73
  74 /* For efficient float-to-int rounding, it is necessary to know whether
  75    floating-point arithmetic may use wider intermediate results.  When
  76    FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
  77    that arithmetic does not widen if double precision is emulated.  */
  78 #ifndef FP_ARITH_MAY_WIDEN
  79 #if defined(HAVE_extendsfdf2)
  80 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
  81 #else
  82 #define FP_ARITH_MAY_WIDEN 0
  83 #endif
  84 #endif
  85
  86 /* Pointers to front-end tables accessed through macros.  */
  87 struct Node *Nodes_Ptr;
  88 Node_Id *Next_Node_Ptr;
  89 Node_Id *Prev_Node_Ptr;
  90 struct Elist_Header *Elists_Ptr;
  91 struct Elmt_Item *Elmts_Ptr;
  92 struct String_Entry *Strings_Ptr;
  93 Char_Code *String_Chars_Ptr;
  94 struct List_Header *List_Headers_Ptr;
  95
  96 /* Highest number in the front-end node table.  */
  97 int max_gnat_nodes;
  98
  99 /* Current node being treated, in case abort called.  */
 100 Node_Id error_gnat_node;
 101
 102 /* True when gigi is being called on an analyzed but unexpanded
 103    tree, and the only purpose of the call is to properly annotate
 104    types with representation information.  */
 105 bool type_annotate_only;
 106
 107 /* Current filename without path.  */
 108 const char *ref_filename;
 109
 110 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
 111    of unconstrained array IN parameters to avoid emitting a great deal of
 112    redundant instructions to recompute them each time.  */
 113 struct GTY (()) parm_attr_d {
 114   int id; /* GTY doesn't like Entity_Id.  */
 115   int dim;
 116   tree first;
 117   tree last;
 118   tree length;
 119 };
 120
 121 typedef struct parm_attr_d *parm_attr;
 122
 123 DEF_VEC_P(parm_attr);
 124 DEF_VEC_ALLOC_P(parm_attr,gc);
 125
 126 struct GTY(()) language_function {
 127   VEC(parm_attr,gc) *parm_attr_cache;
 128 };
 129
 130 #define f_parm_attr_cache \
 131   DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
 132
 133 /* A structure used to gather together information about a statement group.
 134    We use this to gather related statements, for example the "then" part
 135    of a IF.  In the case where it represents a lexical scope, we may also
 136    have a BLOCK node corresponding to it and/or cleanups.  */
 137
 138 struct GTY((chain_next ("%h.previous"))) stmt_group {
 139   struct stmt_group *previous;  /* Previous code group.  */
 140   tree stmt_list;               /* List of statements for this code group.  */
 141   tree block;                   /* BLOCK for this code group, if any.  */
 142   tree cleanups;                /* Cleanups for this code group, if any.  */
 143 };
 144
 145 static GTY(()) struct stmt_group *current_stmt_group;
 146
 147 /* List of unused struct stmt_group nodes.  */
 148 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
 149
 150 /* A structure used to record information on elaboration procedures
 151    we've made and need to process.
 152
 153    ??? gnat_node should be Node_Id, but gengtype gets confused.  */
 154
 155 struct GTY((chain_next ("%h.next"))) elab_info {
 156   struct elab_info *next;       /* Pointer to next in chain.  */
 157   tree elab_proc;               /* Elaboration procedure.  */
 158   int gnat_node;                /* The N_Compilation_Unit.  */
 159 };
 160
 161 static GTY(()) struct elab_info *elab_info_list;
 162
 163 /* Stack of exception pointer variables.  Each entry is the VAR_DECL
 164    that stores the address of the raised exception.  Nonzero means we
 165    are in an exception handler.  Not used in the zero-cost case.  */
 166 static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack;
 167
 168 /* In ZCX case, current exception pointer.  Used to re-raise it.  */
 169 static GTY(()) tree gnu_incoming_exc_ptr;
 170
 171 /* Stack for storing the current elaboration procedure decl.  */
 172 static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack;
 173
 174 /* Stack of labels to be used as a goto target instead of a return in
 175    some functions.  See processing for N_Subprogram_Body.  */
 176 static GTY(()) VEC(tree,gc) *gnu_return_label_stack;
 177
 178 /* Stack of variable for the return value of a function with copy-in/copy-out
 179    parameters.  See processing for N_Subprogram_Body.  */
 180 static GTY(()) VEC(tree,gc) *gnu_return_var_stack;
 181
 182 /* Stack of LOOP_STMT nodes.  */
 183 static GTY(()) VEC(tree,gc) *gnu_loop_label_stack;
 184
 185 /* The stacks for N_{Push,Pop}_*_Label.  */
 186 static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack;
 187 static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack;
 188 static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack;
 189
 190 /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
 191 static enum tree_code gnu_codes[Number_Node_Kinds];
 192
 193 static void init_code_table (void);
 194 static void Compilation_Unit_to_gnu (Node_Id);
 195 static void record_code_position (Node_Id);
 196 static void insert_code_for (Node_Id);
 197 static void add_cleanup (tree, Node_Id);
 198 static void add_stmt_list (List_Id);
 199 static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id);
 200 static tree build_stmt_group (List_Id, bool);
 201 static enum gimplify_status gnat_gimplify_stmt (tree *);
 202 static void elaborate_all_entities (Node_Id);
 203 static void process_freeze_entity (Node_Id);
 204 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
 205 static tree emit_range_check (tree, Node_Id, Node_Id);
 206 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
 207 static tree emit_check (tree, tree, int, Node_Id);
 208 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
 209 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
 210 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
 211 static bool addressable_p (tree, tree);
 212 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 213 static tree extract_values (tree, tree);
 214 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
 215 static tree maybe_implicit_deref (tree);
 216 static void set_expr_location_from_node (tree, Node_Id);
 217 static bool set_end_locus_from_node (tree, Node_Id);
 218 static void set_gnu_expr_location_from_node (tree, Node_Id);
 219 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
 220 static tree build_raise_check (int, enum exception_info_kind);
 221
 222 /* Hooks for debug info back-ends, only supported and used in a restricted set
 223    of configurations.  */
 224 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
 225 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
 226 \f
 227 /* This is the main program of the back-end.  It sets up all the table
 228    structures and then generates code.  */
 229
 230 void
 231 gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
 232       struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
 233       struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
 234       struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
 235       struct List_Header *list_headers_ptr, Nat number_file,
 236       struct File_Info_Type *file_info_ptr,
 237       Entity_Id standard_boolean, Entity_Id standard_integer,
 238       Entity_Id standard_character, Entity_Id standard_long_long_float,
 239       Entity_Id standard_exception_type, Int gigi_operating_mode)
 240 {
 241   Entity_Id gnat_literal;
 242   tree long_long_float_type, exception_type, t, ftype;
 243   tree int64_type = gnat_type_for_size (64, 0);
 244   struct elab_info *info;
 245   int i;
 246
 247   max_gnat_nodes = max_gnat_node;
 248
 249   Nodes_Ptr = nodes_ptr;
 250   Next_Node_Ptr = next_node_ptr;
 251   Prev_Node_Ptr = prev_node_ptr;
 252   Elists_Ptr = elists_ptr;
 253   Elmts_Ptr = elmts_ptr;
 254   Strings_Ptr = strings_ptr;
 255   String_Chars_Ptr = string_chars_ptr;
 256   List_Headers_Ptr = list_headers_ptr;
 257
 258   type_annotate_only = (gigi_operating_mode == 1);
 259
 260   gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
 261
 262   /* Declare the name of the compilation unit as the first global
 263      name in order to make the middle-end fully deterministic.  */
 264   t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
 265   first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
 266
 267   for (i = 0; i < number_file; i++)
 268     {
 269       /* Use the identifier table to make a permanent copy of the filename as
 270          the name table gets reallocated after Gigi returns but before all the
 271          debugging information is output.  The __gnat_to_canonical_file_spec
 272          call translates filenames from pragmas Source_Reference that contain
 273          host style syntax not understood by gdb.  */
 274       const char *filename
 275         = IDENTIFIER_POINTER
 276            (get_identifier
 277             (__gnat_to_canonical_file_spec
 278              (Get_Name_String (file_info_ptr[i].File_Name))));
 279
 280       /* We rely on the order isomorphism between files and line maps.  */
 281       gcc_assert ((int) line_table->used == i);
 282
 283       /* We create the line map for a source file at once, with a fixed number
 284          of columns chosen to avoid jumping over the next power of 2.  */
 285       linemap_add (line_table, LC_ENTER, 0, filename, 1);
 286       linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
 287       linemap_position_for_column (line_table, 252 - 1);
 288       linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
 289     }
 290
 291   /* Initialize ourselves.  */
 292   init_code_table ();
 293   init_gnat_to_gnu ();
 294   init_dummy_type ();
 295
 296   /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
 297      errors.  */
 298   if (type_annotate_only)
 299     {
 300       TYPE_SIZE (void_type_node) = bitsize_zero_node;
 301       TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
 302     }
 303
 304   /* Enable GNAT stack checking method if needed */
 305   if (!Stack_Check_Probes_On_Target)
 306     set_stack_check_libfunc ("_gnat_stack_check");
 307
 308   /* Retrieve alignment settings.  */
 309   double_float_alignment = get_target_double_float_alignment ();
 310   double_scalar_alignment = get_target_double_scalar_alignment ();
 311
 312   /* Record the builtin types.  Define `integer' and `character' first so that
 313      dbx will output them first.  */
 314   record_builtin_type ("integer", integer_type_node, false);
 315   record_builtin_type ("character", unsigned_char_type_node, false);
 316   record_builtin_type ("boolean", boolean_type_node, false);
 317   record_builtin_type ("void", void_type_node, false);
 318
 319   /* Save the type we made for integer as the type for Standard.Integer.  */
 320   save_gnu_tree (Base_Type (standard_integer),
 321                  TYPE_NAME (integer_type_node),
 322                  false);
 323
 324   /* Likewise for character as the type for Standard.Character.  */
 325   save_gnu_tree (Base_Type (standard_character),
 326                  TYPE_NAME (unsigned_char_type_node),
 327                  false);
 328
 329   /* Likewise for boolean as the type for Standard.Boolean.  */
 330   save_gnu_tree (Base_Type (standard_boolean),
 331                  TYPE_NAME (boolean_type_node),
 332                  false);
 333   gnat_literal = First_Literal (Base_Type (standard_boolean));
 334   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 335   gcc_assert (t == boolean_false_node);
 336   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 337                        boolean_type_node, t, true, false, false, false,
 338                        NULL, gnat_literal);
 339   DECL_IGNORED_P (t) = 1;
 340   save_gnu_tree (gnat_literal, t, false);
 341   gnat_literal = Next_Literal (gnat_literal);
 342   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 343   gcc_assert (t == boolean_true_node);
 344   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 345                        boolean_type_node, t, true, false, false, false,
 346                        NULL, gnat_literal);
 347   DECL_IGNORED_P (t) = 1;
 348   save_gnu_tree (gnat_literal, t, false);
 349
 350   void_ftype = build_function_type_list (void_type_node, NULL_TREE);
 351   ptr_void_ftype = build_pointer_type (void_ftype);
 352
 353   /* Now declare run-time functions.  */
 354   ftype = build_function_type_list (ptr_void_type_node, sizetype, NULL_TREE);
 355
 356   /* malloc is a function declaration tree for a function to allocate
 357      memory.  */
 358   malloc_decl
 359     = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
 360                            ftype, NULL_TREE, false, true, true, true, NULL,
 361                            Empty);
 362   DECL_IS_MALLOC (malloc_decl) = 1;
 363
 364   /* malloc32 is a function declaration tree for a function to allocate
 365      32-bit memory on a 64-bit system.  Needed only on 64-bit VMS.  */
 366   malloc32_decl
 367     = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
 368                            ftype, NULL_TREE, false, true, true, true, NULL,
 369                            Empty);
 370   DECL_IS_MALLOC (malloc32_decl) = 1;
 371
 372   /* free is a function declaration tree for a function to free memory.  */
 373   free_decl
 374     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
 375                            build_function_type_list (void_type_node,
 376                                                      ptr_void_type_node,
 377                                                      NULL_TREE),
 378                            NULL_TREE, false, true, true, true, NULL, Empty);
 379
 380   /* This is used for 64-bit multiplication with overflow checking.  */
 381   mulv64_decl
 382     = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
 383                            build_function_type_list (int64_type, int64_type,
 384                                                      int64_type, NULL_TREE),
 385                            NULL_TREE, false, true, true, true, NULL, Empty);
 386
 387   /* Name of the _Parent field in tagged record types.  */
 388   parent_name_id = get_identifier (Get_Name_String (Name_uParent));
 389
 390   /* Name of the Exception_Data type defined in System.Standard_Library.  */
 391   exception_data_name_id
 392     = get_identifier ("system__standard_library__exception_data");
 393
 394   /* Make the types and functions used for exception processing.  */
 395   jmpbuf_type
 396     = build_array_type (gnat_type_for_mode (Pmode, 0),
 397                         build_index_type (size_int (5)));
 398   record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
 399   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
 400
 401   /* Functions to get and set the jumpbuf pointer for the current thread.  */
 402   get_jmpbuf_decl
 403     = create_subprog_decl
 404       (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
 405        NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
 406        NULL_TREE, false, true, true, true, NULL, Empty);
 407   DECL_IGNORED_P (get_jmpbuf_decl) = 1;
 408
 409   set_jmpbuf_decl
 410     = create_subprog_decl
 411       (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
 412        NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
 413                                             NULL_TREE),
 414        NULL_TREE, false, true, true, true, NULL, Empty);
 415   DECL_IGNORED_P (set_jmpbuf_decl) = 1;
 416
 417   /* setjmp returns an integer and has one operand, which is a pointer to
 418      a jmpbuf.  */
 419   setjmp_decl
 420     = create_subprog_decl
 421       (get_identifier ("__builtin_setjmp"), NULL_TREE,
 422        build_function_type_list (integer_type_node, jmpbuf_ptr_type,
 423                                  NULL_TREE),
 424        NULL_TREE, false, true, true, true, NULL, Empty);
 425   DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
 426   DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
 427
 428   /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
 429      address.  */
 430   update_setjmp_buf_decl
 431     = create_subprog_decl
 432       (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
 433        build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
 434        NULL_TREE, false, true, true, true, NULL, Empty);
 435   DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
 436   DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
 437
 438   /* Hooks to call when entering/leaving an exception handler.  */
 439   ftype
 440     = build_function_type_list (void_type_node, ptr_void_type_node, NULL_TREE);
 441
 442   begin_handler_decl
 443     = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
 444                            ftype, NULL_TREE, false, true, true, true, NULL,
 445                            Empty);
 446   DECL_IGNORED_P (begin_handler_decl) = 1;
 447
 448   end_handler_decl
 449     = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
 450                            ftype, NULL_TREE, false, true, true, true, NULL,
 451                            Empty);
 452   DECL_IGNORED_P (end_handler_decl) = 1;
 453
 454   reraise_zcx_decl
 455     = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
 456                            ftype, NULL_TREE, false, true, true, true, NULL,
 457                            Empty);
 458   DECL_IGNORED_P (reraise_zcx_decl) = 1;
 459
 460   /* If in no exception handlers mode, all raise statements are redirected to
 461      __gnat_last_chance_handler.  No need to redefine raise_nodefer_decl since
 462      this procedure will never be called in this mode.  */
 463   if (No_Exception_Handlers_Set ())
 464     {
 465       tree decl
 466         = create_subprog_decl
 467           (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
 468            build_function_type_list (void_type_node,
 469                                      build_pointer_type
 470                                      (unsigned_char_type_node),
 471                                      integer_type_node, NULL_TREE),
 472            NULL_TREE, false, true, true, true, NULL, Empty);
 473       TREE_THIS_VOLATILE (decl) = 1;
 474       TREE_SIDE_EFFECTS (decl) = 1;
 475       TREE_TYPE (decl)
 476         = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
 477       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 478         gnat_raise_decls[i] = decl;
 479     }
 480   else
 481     {
 482       /* Otherwise, make one decl for each exception reason.  */
 483       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 484         gnat_raise_decls[i] = build_raise_check (i, exception_simple);
 485       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
 486         gnat_raise_decls_ext[i]
 487           = build_raise_check (i,
 488                                i == CE_Index_Check_Failed
 489                                || i == CE_Range_Check_Failed
 490                                || i == CE_Invalid_Data
 491                                ? exception_range : exception_column);
 492     }
 493
 494   /* Set the types that GCC and Gigi use from the front end.  */
 495   exception_type
 496     = gnat_to_gnu_entity (Base_Type (standard_exception_type),  NULL_TREE, 0);
 497   except_type_node = TREE_TYPE (exception_type);
 498
 499   /* Make other functions used for exception processing.  */
 500   get_excptr_decl
 501     = create_subprog_decl
 502       (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
 503        build_function_type_list (build_pointer_type (except_type_node),
 504                                  NULL_TREE),
 505      NULL_TREE, false, true, true, true, NULL, Empty);
 506
 507   raise_nodefer_decl
 508     = create_subprog_decl
 509       (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
 510        build_function_type_list (void_type_node,
 511                                  build_pointer_type (except_type_node),
 512                                  NULL_TREE),
 513        NULL_TREE, false, true, true, true, NULL, Empty);
 514
 515   /* Indicate that it never returns.  */
 516   TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
 517   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
 518   TREE_TYPE (raise_nodefer_decl)
 519     = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
 520                             TYPE_QUAL_VOLATILE);
 521
 522   /* Build the special descriptor type and its null node if needed.  */
 523   if (TARGET_VTABLE_USES_DESCRIPTORS)
 524     {
 525       tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
 526       tree field_list = NULL_TREE;
 527       int j;
 528       VEC(constructor_elt,gc) *null_vec = NULL;
 529       constructor_elt *elt;
 530
 531       fdesc_type_node = make_node (RECORD_TYPE);
 532       VEC_safe_grow (constructor_elt, gc, null_vec,
 533                      TARGET_VTABLE_USES_DESCRIPTORS);
 534       elt = (VEC_address (constructor_elt,null_vec)
 535              + TARGET_VTABLE_USES_DESCRIPTORS - 1);
 536
 537       for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
 538         {
 539           tree field
 540             = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
 541                                  NULL_TREE, NULL_TREE, 0, 1);
 542           TREE_CHAIN (field) = field_list;
 543           field_list = field;
 544           elt->index = field;
 545           elt->value = null_node;
 546           elt--;
 547         }
 548
 549       finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
 550       record_builtin_type ("descriptor", fdesc_type_node, true);
 551       null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
 552     }
 553
 554   long_long_float_type
 555     = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
 556
 557   if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
 558     {
 559       /* In this case, the builtin floating point types are VAX float,
 560          so make up a type for use.  */
 561       longest_float_type_node = make_node (REAL_TYPE);
 562       TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
 563       layout_type (longest_float_type_node);
 564       record_builtin_type ("longest float type", longest_float_type_node,
 565                            false);
 566     }
 567   else
 568     longest_float_type_node = TREE_TYPE (long_long_float_type);
 569
 570   /* Dummy objects to materialize "others" and "all others" in the exception
 571      tables.  These are exported by a-exexpr-gcc.adb, so see this unit for
 572      the types to use.  */
 573   others_decl
 574     = create_var_decl (get_identifier ("OTHERS"),
 575                        get_identifier ("__gnat_others_value"),
 576                        integer_type_node, NULL_TREE, true, false, true, false,
 577                        NULL, Empty);
 578
 579   all_others_decl
 580     = create_var_decl (get_identifier ("ALL_OTHERS"),
 581                        get_identifier ("__gnat_all_others_value"),
 582                        integer_type_node, NULL_TREE, true, false, true, false,
 583                        NULL, Empty);
 584
 585   main_identifier_node = get_identifier ("main");
 586
 587   /* Install the builtins we might need, either internally or as
 588      user available facilities for Intrinsic imports.  */
 589   gnat_install_builtins ();
 590
 591   VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE);
 592   VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE);
 593   VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE);
 594   VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE);
 595
 596   /* Process any Pragma Ident for the main unit.  */
 597 #ifdef ASM_OUTPUT_IDENT
 598   if (Present (Ident_String (Main_Unit)))
 599     ASM_OUTPUT_IDENT
 600       (asm_out_file,
 601        TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
 602 #endif
 603
 604   /* If we are using the GCC exception mechanism, let GCC know.  */
 605   if (Exception_Mechanism == Back_End_Exceptions)
 606     gnat_init_gcc_eh ();
 607
 608   /* Now translate the compilation unit proper.  */
 609   Compilation_Unit_to_gnu (gnat_root);
 610
 611   /* Finally see if we have any elaboration procedures to deal with.  */
 612   for (info = elab_info_list; info; info = info->next)
 613     {
 614       tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
 615
 616       /* We should have a BIND_EXPR but it may not have any statements in it.
 617          If it doesn't have any, we have nothing to do except for setting the
 618          flag on the GNAT node.  Otherwise, process the function as others.  */
 619       gnu_stmts = gnu_body;
 620       if (TREE_CODE (gnu_stmts) == BIND_EXPR)
 621         gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
 622       if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
 623         Set_Has_No_Elaboration_Code (info->gnat_node, 1);
 624       else
 625         {
 626           begin_subprog_body (info->elab_proc);
 627           end_subprog_body (gnu_body);
 628         }
 629     }
 630
 631   /* We cannot track the location of errors past this point.  */
 632   error_gnat_node = Empty;
 633 }
 634 \f
 635 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
 636    CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext.  */
 637
 638 static tree
 639 build_raise_check (int check, enum exception_info_kind kind)
 640 {
 641   char name[21];
 642   tree result, ftype;
 643
 644   if (kind == exception_simple)
 645     {
 646       sprintf (name, "__gnat_rcheck_%.2d", check);
 647       ftype
 648         = build_function_type_list (void_type_node,
 649                                     build_pointer_type
 650                                     (unsigned_char_type_node),
 651                                     integer_type_node, NULL_TREE);
 652     }
 653   else
 654     {
 655       tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
 656       sprintf (name, "__gnat_rcheck_%.2d_ext", check);
 657       ftype
 658         = build_function_type_list (void_type_node,
 659                                     build_pointer_type
 660                                     (unsigned_char_type_node),
 661                                     integer_type_node, integer_type_node,
 662                                     t, t, NULL_TREE);
 663     }
 664
 665   result
 666     = create_subprog_decl (get_identifier (name), NULL_TREE, ftype, NULL_TREE,
 667                            false, true, true, true, NULL, Empty);
 668
 669   /* Indicate that it never returns.  */
 670   TREE_THIS_VOLATILE (result) = 1;
 671   TREE_SIDE_EFFECTS (result) = 1;
 672   TREE_TYPE (result)
 673     = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE);
 674
 675   return result;
 676 }
 677 \f
 678 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
 679    an N_Attribute_Reference.  */
 680
 681 static int
 682 lvalue_required_for_attribute_p (Node_Id gnat_node)
 683 {
 684   switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
 685     {
 686     case Attr_Pos:
 687     case Attr_Val:
 688     case Attr_Pred:
 689     case Attr_Succ:
 690     case Attr_First:
 691     case Attr_Last:
 692     case Attr_Range_Length:
 693     case Attr_Length:
 694     case Attr_Object_Size:
 695     case Attr_Value_Size:
 696     case Attr_Component_Size:
 697     case Attr_Max_Size_In_Storage_Elements:
 698     case Attr_Min:
 699     case Attr_Max:
 700     case Attr_Null_Parameter:
 701     case Attr_Passed_By_Reference:
 702     case Attr_Mechanism_Code:
 703       return 0;
 704
 705     case Attr_Address:
 706     case Attr_Access:
 707     case Attr_Unchecked_Access:
 708     case Attr_Unrestricted_Access:
 709     case Attr_Code_Address:
 710     case Attr_Pool_Address:
 711     case Attr_Size:
 712     case Attr_Alignment:
 713     case Attr_Bit_Position:
 714     case Attr_Position:
 715     case Attr_First_Bit:
 716     case Attr_Last_Bit:
 717     case Attr_Bit:
 718     case Attr_Asm_Input:
 719     case Attr_Asm_Output:
 720     default:
 721       return 1;
 722     }
 723 }
 724
 725 /* Return a positive value if an lvalue is required for GNAT_NODE.  GNU_TYPE
 726    is the type that will be used for GNAT_NODE in the translated GNU tree.
 727    CONSTANT indicates whether the underlying object represented by GNAT_NODE
 728    is constant in the Ada sense.  If it is, ADDRESS_OF_CONSTANT indicates
 729    whether its value is the address of a constant and ALIASED whether it is
 730    aliased.  If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
 731
 732    The function climbs up the GNAT tree starting from the node and returns 1
 733    upon encountering a node that effectively requires an lvalue downstream.
 734    It returns int instead of bool to facilitate usage in non-purely binary
 735    logic contexts.  */
 736
 737 static int
 738 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
 739                    bool address_of_constant, bool aliased)
 740 {
 741   Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
 742
 743   switch (Nkind (gnat_parent))
 744     {
 745     case N_Reference:
 746       return 1;
 747
 748     case N_Attribute_Reference:
 749       return lvalue_required_for_attribute_p (gnat_parent);
 750
 751     case N_Parameter_Association:
 752     case N_Function_Call:
 753     case N_Procedure_Call_Statement:
 754       /* If the parameter is by reference, an lvalue is required.  */
 755       return (!constant
 756               || must_pass_by_ref (gnu_type)
 757               || default_pass_by_ref (gnu_type));
 758
 759     case N_Indexed_Component:
 760       /* Only the array expression can require an lvalue.  */
 761       if (Prefix (gnat_parent) != gnat_node)
 762         return 0;
 763
 764       /* ??? Consider that referencing an indexed component with a
 765          non-constant index forces the whole aggregate to memory.
 766          Note that N_Integer_Literal is conservative, any static
 767          expression in the RM sense could probably be accepted.  */
 768       for (gnat_temp = First (Expressions (gnat_parent));
 769            Present (gnat_temp);
 770            gnat_temp = Next (gnat_temp))
 771         if (Nkind (gnat_temp) != N_Integer_Literal)
 772           return 1;
 773
 774       /* ... fall through ... */
 775
 776     case N_Slice:
 777       /* Only the array expression can require an lvalue.  */
 778       if (Prefix (gnat_parent) != gnat_node)
 779         return 0;
 780
 781       aliased |= Has_Aliased_Components (Etype (gnat_node));
 782       return lvalue_required_p (gnat_parent, gnu_type, constant,
 783                                 address_of_constant, aliased);
 784
 785     case N_Selected_Component:
 786       aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
 787       return lvalue_required_p (gnat_parent, gnu_type, constant,
 788                                 address_of_constant, aliased);
 789
 790     case N_Object_Renaming_Declaration:
 791       /* We need to make a real renaming only if the constant object is
 792          aliased or if we may use a renaming pointer; otherwise we can
 793          optimize and return the rvalue.  We make an exception if the object
 794          is an identifier since in this case the rvalue can be propagated
 795          attached to the CONST_DECL.  */
 796       return (!constant
 797               || aliased
 798               /* This should match the constant case of the renaming code.  */
 799               || Is_Composite_Type
 800                  (Underlying_Type (Etype (Name (gnat_parent))))
 801               || Nkind (Name (gnat_parent)) == N_Identifier);
 802
 803     case N_Object_Declaration:
 804       /* We cannot use a constructor if this is an atomic object because
 805          the actual assignment might end up being done component-wise.  */
 806       return (!constant
 807               ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 808                  && Is_Atomic (Defining_Entity (gnat_parent)))
 809               /* We don't use a constructor if this is a class-wide object
 810                  because the effective type of the object is the equivalent
 811                  type of the class-wide subtype and it smashes most of the
 812                  data into an array of bytes to which we cannot convert.  */
 813               || Ekind ((Etype (Defining_Entity (gnat_parent))))
 814                  == E_Class_Wide_Subtype);
 815
 816     case N_Assignment_Statement:
 817       /* We cannot use a constructor if the LHS is an atomic object because
 818          the actual assignment might end up being done component-wise.  */
 819       return (!constant
 820               || Name (gnat_parent) == gnat_node
 821               || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 822                   && Is_Atomic (Entity (Name (gnat_parent)))));
 823
 824     case N_Unchecked_Type_Conversion:
 825         if (!constant)
 826           return 1;
 827
 828       /* ... fall through ... */
 829
 830     case N_Type_Conversion:
 831     case N_Qualified_Expression:
 832       /* We must look through all conversions because we may need to bypass
 833          an intermediate conversion that is meant to be purely formal.  */
 834      return lvalue_required_p (gnat_parent,
 835                                get_unpadded_type (Etype (gnat_parent)),
 836                                constant, address_of_constant, aliased);
 837
 838     case N_Allocator:
 839       /* We should only reach here through the N_Qualified_Expression case.
 840          Force an lvalue for composite types since a block-copy to the newly
 841          allocated area of memory is made.  */
 842       return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
 843
 844    case N_Explicit_Dereference:
 845       /* We look through dereferences for address of constant because we need
 846          to handle the special cases listed above.  */
 847       if (constant && address_of_constant)
 848         return lvalue_required_p (gnat_parent,
 849                                   get_unpadded_type (Etype (gnat_parent)),
 850                                   true, false, true);
 851
 852       /* ... fall through ... */
 853
 854     default:
 855       return 0;
 856     }
 857
 858   gcc_unreachable ();
 859 }
 860
 861 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
 862    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer
 863    to where we should place the result type.  */
 864
 865 static tree
 866 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 867 {
 868   Node_Id gnat_temp, gnat_temp_type;
 869   tree gnu_result, gnu_result_type;
 870
 871   /* Whether we should require an lvalue for GNAT_NODE.  Needed in
 872      specific circumstances only, so evaluated lazily.  < 0 means
 873      unknown, > 0 means known true, 0 means known false.  */
 874   int require_lvalue = -1;
 875
 876   /* If GNAT_NODE is a constant, whether we should use the initialization
 877      value instead of the constant entity, typically for scalars with an
 878      address clause when the parent doesn't require an lvalue.  */
 879   bool use_constant_initializer = false;
 880
 881   /* If the Etype of this node does not equal the Etype of the Entity,
 882      something is wrong with the entity map, probably in generic
 883      instantiation. However, this does not apply to types. Since we sometime
 884      have strange Ekind's, just do this test for objects. Also, if the Etype of
 885      the Entity is private, the Etype of the N_Identifier is allowed to be the
 886      full type and also we consider a packed array type to be the same as the
 887      original type. Similarly, a class-wide type is equivalent to a subtype of
 888      itself. Finally, if the types are Itypes, one may be a copy of the other,
 889      which is also legal.  */
 890   gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
 891                ? gnat_node : Entity (gnat_node));
 892   gnat_temp_type = Etype (gnat_temp);
 893
 894   gcc_assert (Etype (gnat_node) == gnat_temp_type
 895               || (Is_Packed (gnat_temp_type)
 896                   && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
 897               || (Is_Class_Wide_Type (Etype (gnat_node)))
 898               || (IN (Ekind (gnat_temp_type), Private_Kind)
 899                   && Present (Full_View (gnat_temp_type))
 900                   && ((Etype (gnat_node) == Full_View (gnat_temp_type))
 901                       || (Is_Packed (Full_View (gnat_temp_type))
 902                           && (Etype (gnat_node)
 903                               == Packed_Array_Type (Full_View
 904                                                     (gnat_temp_type))))))
 905               || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
 906               || !(Ekind (gnat_temp) == E_Variable
 907                    || Ekind (gnat_temp) == E_Component
 908                    || Ekind (gnat_temp) == E_Constant
 909                    || Ekind (gnat_temp) == E_Loop_Parameter
 910                    || IN (Ekind (gnat_temp), Formal_Kind)));
 911
 912   /* If this is a reference to a deferred constant whose partial view is an
 913      unconstrained private type, the proper type is on the full view of the
 914      constant, not on the full view of the type, which may be unconstrained.
 915
 916      This may be a reference to a type, for example in the prefix of the
 917      attribute Position, generated for dispatching code (see Make_DT in
 918      exp_disp,adb). In that case we need the type itself, not is parent,
 919      in particular if it is a derived type  */
 920   if (Ekind (gnat_temp) == E_Constant
 921       && Is_Private_Type (gnat_temp_type)
 922       && (Has_Unknown_Discriminants (gnat_temp_type)
 923           || (Present (Full_View (gnat_temp_type))
 924               && Has_Discriminants (Full_View (gnat_temp_type))))
 925       && Present (Full_View (gnat_temp)))
 926     {
 927       gnat_temp = Full_View (gnat_temp);
 928       gnat_temp_type = Etype (gnat_temp);
 929     }
 930   else
 931     {
 932       /* We want to use the Actual_Subtype if it has already been elaborated,
 933          otherwise the Etype.  Avoid using Actual_Subtype for packed arrays to
 934          simplify things.  */
 935       if ((Ekind (gnat_temp) == E_Constant
 936            || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
 937           && !(Is_Array_Type (Etype (gnat_temp))
 938                && Present (Packed_Array_Type (Etype (gnat_temp))))
 939           && Present (Actual_Subtype (gnat_temp))
 940           && present_gnu_tree (Actual_Subtype (gnat_temp)))
 941         gnat_temp_type = Actual_Subtype (gnat_temp);
 942       else
 943         gnat_temp_type = Etype (gnat_node);
 944     }
 945
 946   /* Expand the type of this identifier first, in case it is an enumeral
 947      literal, which only get made when the type is expanded.  There is no
 948      order-of-elaboration issue here.  */
 949   gnu_result_type = get_unpadded_type (gnat_temp_type);
 950
 951   /* If this is a non-imported scalar constant with an address clause,
 952      retrieve the value instead of a pointer to be dereferenced unless
 953      an lvalue is required.  This is generally more efficient and actually
 954      required if this is a static expression because it might be used
 955      in a context where a dereference is inappropriate, such as a case
 956      statement alternative or a record discriminant.  There is no possible
 957      volatile-ness short-circuit here since Volatile constants must be
 958      imported per C.6.  */
 959   if (Ekind (gnat_temp) == E_Constant
 960       && Is_Scalar_Type (gnat_temp_type)
 961       && !Is_Imported (gnat_temp)
 962       && Present (Address_Clause (gnat_temp)))
 963     {
 964       require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
 965                                           false, Is_Aliased (gnat_temp));
 966       use_constant_initializer = !require_lvalue;
 967     }
 968
 969   if (use_constant_initializer)
 970     {
 971       /* If this is a deferred constant, the initializer is attached to
 972          the full view.  */
 973       if (Present (Full_View (gnat_temp)))
 974         gnat_temp = Full_View (gnat_temp);
 975
 976       gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
 977     }
 978   else
 979     gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
 980
 981   /* Some objects (such as parameters passed by reference, globals of
 982      variable size, and renamed objects) actually represent the address
 983      of the object.  In that case, we must do the dereference.  Likewise,
 984      deal with parameters to foreign convention subprograms.  */
 985   if (DECL_P (gnu_result)
 986       && (DECL_BY_REF_P (gnu_result)
 987           || (TREE_CODE (gnu_result) == PARM_DECL
 988               && DECL_BY_COMPONENT_PTR_P (gnu_result))))
 989     {
 990       const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
 991       tree renamed_obj;
 992
 993       if (TREE_CODE (gnu_result) == PARM_DECL
 994           && DECL_BY_DOUBLE_REF_P (gnu_result))
 995         {
 996           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
 997           if (TREE_CODE (gnu_result) == INDIRECT_REF)
 998             TREE_THIS_NOTRAP (gnu_result) = 1;
 999         }
1000
1001       if (TREE_CODE (gnu_result) == PARM_DECL
1002           && DECL_BY_COMPONENT_PTR_P (gnu_result))
1003         {
1004           gnu_result
1005             = build_unary_op (INDIRECT_REF, NULL_TREE,
1006                               convert (build_pointer_type (gnu_result_type),
1007                                        gnu_result));
1008           if (TREE_CODE (gnu_result) == INDIRECT_REF)
1009             TREE_THIS_NOTRAP (gnu_result) = 1;
1010         }
1011
1012       /* If it's a renaming pointer and we are at the right binding level,
1013          we can reference the renamed object directly, since the renamed
1014          expression has been protected against multiple evaluations.  */
1015       else if (TREE_CODE (gnu_result) == VAR_DECL
1016                && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result))
1017                && (!DECL_RENAMING_GLOBAL_P (gnu_result)
1018                    || global_bindings_p ()))
1019         gnu_result = renamed_obj;
1020
1021       /* Return the underlying CST for a CONST_DECL like a few lines below,
1022          after dereferencing in this case.  */
1023       else if (TREE_CODE (gnu_result) == CONST_DECL)
1024         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
1025                                      DECL_INITIAL (gnu_result));
1026
1027       else
1028         {
1029           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1030           if (TREE_CODE (gnu_result) == INDIRECT_REF
1031               && No (Address_Clause (gnat_temp)))
1032             TREE_THIS_NOTRAP (gnu_result) = 1;
1033         }
1034
1035       if (read_only)
1036         TREE_READONLY (gnu_result) = 1;
1037     }
1038
1039   /* The GNAT tree has the type of a function as the type of its result.  Also
1040      use the type of the result if the Etype is a subtype which is nominally
1041      unconstrained.  But remove any padding from the resulting type.  */
1042   if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1043       || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
1044     {
1045       gnu_result_type = TREE_TYPE (gnu_result);
1046       if (TYPE_IS_PADDING_P (gnu_result_type))
1047         gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1048     }
1049
1050   /* If we have a constant declaration and its initializer, try to return the
1051      latter to avoid the need to call fold in lots of places and the need for
1052      elaboration code if this identifier is used as an initializer itself.
1053      Don't do it for aggregate types that contain a placeholder since their
1054      initializers cannot be manipulated easily.  */
1055   if (TREE_CONSTANT (gnu_result)
1056       && DECL_P (gnu_result)
1057       && DECL_INITIAL (gnu_result)
1058       && !(AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
1059            && type_contains_placeholder_p (TREE_TYPE (gnu_result))))
1060     {
1061       bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1062                             && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1063       bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1064                                   && DECL_CONST_ADDRESS_P (gnu_result));
1065
1066       /* If there is a (corresponding) variable or this is the address of a
1067          constant, we only want to return the initializer if an lvalue isn't
1068          required.  Evaluate this now if we have not already done so.  */
1069       if ((!constant_only || address_of_constant) && require_lvalue < 0)
1070         require_lvalue
1071           = lvalue_required_p (gnat_node, gnu_result_type, true,
1072                                address_of_constant, Is_Aliased (gnat_temp));
1073
1074       /* ??? We need to unshare the initializer if the object is external
1075          as such objects are not marked for unsharing if we are not at the
1076          global level.  This should be fixed in add_decl_expr.  */
1077       if ((constant_only && !address_of_constant) || !require_lvalue)
1078         gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
1079     }
1080
1081   *gnu_result_type_p = gnu_result_type;
1082
1083   return gnu_result;
1084 }
1085 \f
1086 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
1087    any statements we generate.  */
1088
1089 static tree
1090 Pragma_to_gnu (Node_Id gnat_node)
1091 {
1092   Node_Id gnat_temp;
1093   tree gnu_result = alloc_stmt_list ();
1094
1095   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1096      annotating types.  */
1097   if (type_annotate_only
1098       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1099     return gnu_result;
1100
1101   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1102     {
1103     case Pragma_Inspection_Point:
1104       /* Do nothing at top level: all such variables are already viewable.  */
1105       if (global_bindings_p ())
1106         break;
1107
1108       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1109            Present (gnat_temp);
1110            gnat_temp = Next (gnat_temp))
1111         {
1112           Node_Id gnat_expr = Expression (gnat_temp);
1113           tree gnu_expr = gnat_to_gnu (gnat_expr);
1114           int use_address;
1115           enum machine_mode mode;
1116           tree asm_constraint = NULL_TREE;
1117 #ifdef ASM_COMMENT_START
1118           char *comment;
1119 #endif
1120
1121           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1122             gnu_expr = TREE_OPERAND (gnu_expr, 0);
1123
1124           /* Use the value only if it fits into a normal register,
1125              otherwise use the address.  */
1126           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1127           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1128                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1129                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1130
1131           if (use_address)
1132             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1133
1134 #ifdef ASM_COMMENT_START
1135           comment = concat (ASM_COMMENT_START,
1136                             " inspection point: ",
1137                             Get_Name_String (Chars (gnat_expr)),
1138                             use_address ? " address" : "",
1139                             " is in %0",
1140                             NULL);
1141           asm_constraint = build_string (strlen (comment), comment);
1142           free (comment);
1143 #endif
1144           gnu_expr = build5 (ASM_EXPR, void_type_node,
1145                              asm_constraint,
1146                              NULL_TREE,
1147                              tree_cons
1148                              (build_tree_list (NULL_TREE,
1149                                                build_string (1, "g")),
1150                               gnu_expr, NULL_TREE),
1151                              NULL_TREE, NULL_TREE);
1152           ASM_VOLATILE_P (gnu_expr) = 1;
1153           set_expr_location_from_node (gnu_expr, gnat_node);
1154           append_to_statement_list (gnu_expr, &gnu_result);
1155         }
1156       break;
1157
1158     case Pragma_Optimize:
1159       switch (Chars (Expression
1160                      (First (Pragma_Argument_Associations (gnat_node)))))
1161         {
1162         case Name_Time:  case Name_Space:
1163           if (!optimize)
1164             post_error ("insufficient -O value?", gnat_node);
1165           break;
1166
1167         case Name_Off:
1168           if (optimize)
1169             post_error ("must specify -O0?", gnat_node);
1170           break;
1171
1172         default:
1173           gcc_unreachable ();
1174         }
1175       break;
1176
1177     case Pragma_Reviewable:
1178       if (write_symbols == NO_DEBUG)
1179         post_error ("must specify -g?", gnat_node);
1180       break;
1181     }
1182
1183   return gnu_result;
1184 }
1185 \f
1186 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1187    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
1188    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
1189
1190 static tree
1191 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1192 {
1193   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1194   tree gnu_type = TREE_TYPE (gnu_prefix);
1195   tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1196   bool prefix_unused = false;
1197
1198   /* If the input is a NULL_EXPR, make a new one.  */
1199   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1200     {
1201       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1202       *gnu_result_type_p = gnu_result_type;
1203       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1204     }
1205
1206   switch (attribute)
1207     {
1208     case Attr_Pos:
1209     case Attr_Val:
1210       /* These are just conversions since representation clauses for
1211          enumeration types are handled in the front-end.  */
1212       {
1213         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1214         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1215         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1216         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1217                                          checkp, checkp, true, gnat_node);
1218       }
1219       break;
1220
1221     case Attr_Pred:
1222     case Attr_Succ:
1223       /* These just add or subtract the constant 1 since representation
1224          clauses for enumeration types are handled in the front-end.  */
1225       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1226       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1227
1228       if (Do_Range_Check (First (Expressions (gnat_node))))
1229         {
1230           gnu_expr = gnat_protect_expr (gnu_expr);
1231           gnu_expr
1232             = emit_check
1233               (build_binary_op (EQ_EXPR, boolean_type_node,
1234                                 gnu_expr,
1235                                 attribute == Attr_Pred
1236                                 ? TYPE_MIN_VALUE (gnu_result_type)
1237                                 : TYPE_MAX_VALUE (gnu_result_type)),
1238                gnu_expr, CE_Range_Check_Failed, gnat_node);
1239         }
1240
1241       gnu_result
1242         = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1243                            gnu_result_type, gnu_expr,
1244                            convert (gnu_result_type, integer_one_node));
1245       break;
1246
1247     case Attr_Address:
1248     case Attr_Unrestricted_Access:
1249       /* Conversions don't change addresses but can cause us to miss the
1250          COMPONENT_REF case below, so strip them off.  */
1251       gnu_prefix = remove_conversions (gnu_prefix,
1252                                        !Must_Be_Byte_Aligned (gnat_node));
1253
1254       /* If we are taking 'Address of an unconstrained object, this is the
1255          pointer to the underlying array.  */
1256       if (attribute == Attr_Address)
1257         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1258
1259       /* If we are building a static dispatch table, we have to honor
1260          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1261          with the C++ ABI.  We do it in the non-static case as well,
1262          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
1263       else if (TARGET_VTABLE_USES_DESCRIPTORS
1264                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1265         {
1266           tree gnu_field, t;
1267           /* Descriptors can only be built here for top-level functions.  */
1268           bool build_descriptor = (global_bindings_p () != 0);
1269           int i;
1270           VEC(constructor_elt,gc) *gnu_vec = NULL;
1271           constructor_elt *elt;
1272
1273           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1274
1275           /* If we're not going to build the descriptor, we have to retrieve
1276              the one which will be built by the linker (or by the compiler
1277              later if a static chain is requested).  */
1278           if (!build_descriptor)
1279             {
1280               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1281               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1282                                          gnu_result);
1283               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1284             }
1285
1286           VEC_safe_grow (constructor_elt, gc, gnu_vec,
1287                          TARGET_VTABLE_USES_DESCRIPTORS);
1288           elt = (VEC_address (constructor_elt, gnu_vec)
1289                  + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1290           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1291                i < TARGET_VTABLE_USES_DESCRIPTORS;
1292                gnu_field = TREE_CHAIN (gnu_field), i++)
1293             {
1294               if (build_descriptor)
1295                 {
1296                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1297                               build_int_cst (NULL_TREE, i));
1298                   TREE_CONSTANT (t) = 1;
1299                 }
1300               else
1301                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1302                             gnu_field, NULL_TREE);
1303
1304               elt->index = gnu_field;
1305               elt->value = t;
1306               elt--;
1307             }
1308
1309           gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1310           break;
1311         }
1312
1313       /* ... fall through ... */
1314
1315     case Attr_Access:
1316     case Attr_Unchecked_Access:
1317     case Attr_Code_Address:
1318       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1319       gnu_result
1320         = build_unary_op (((attribute == Attr_Address
1321                             || attribute == Attr_Unrestricted_Access)
1322                            && !Must_Be_Byte_Aligned (gnat_node))
1323                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
1324                           gnu_result_type, gnu_prefix);
1325
1326       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1327          don't try to build a trampoline.  */
1328       if (attribute == Attr_Code_Address)
1329         {
1330           for (gnu_expr = gnu_result;
1331                CONVERT_EXPR_P (gnu_expr);
1332                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1333             TREE_CONSTANT (gnu_expr) = 1;
1334
1335           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1336             TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1337         }
1338
1339       /* For other address attributes applied to a nested function,
1340          find an inner ADDR_EXPR and annotate it so that we can issue
1341          a useful warning with -Wtrampolines.  */
1342       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1343         {
1344           for (gnu_expr = gnu_result;
1345                CONVERT_EXPR_P (gnu_expr);
1346                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1347             ;
1348
1349           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1350               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1351             {
1352               set_expr_location_from_node (gnu_expr, gnat_node);
1353
1354               /* Check that we're not violating the No_Implicit_Dynamic_Code
1355                  restriction.  Be conservative if we don't know anything
1356                  about the trampoline strategy for the target.  */
1357               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1358             }
1359         }
1360       break;
1361
1362     case Attr_Pool_Address:
1363       {
1364         tree gnu_obj_type;
1365         tree gnu_ptr = gnu_prefix;
1366
1367         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1368
1369         /* If this is an unconstrained array, we know the object has been
1370            allocated with the template in front of the object.  So compute
1371            the template address.  */
1372         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1373           gnu_ptr
1374             = convert (build_pointer_type
1375                        (TYPE_OBJECT_RECORD_TYPE
1376                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1377                        gnu_ptr);
1378
1379         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1380         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1381             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1382           {
1383             tree gnu_char_ptr_type
1384               = build_pointer_type (unsigned_char_type_node);
1385             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1386             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1387             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1388                                        gnu_ptr, gnu_pos);
1389           }
1390
1391         gnu_result = convert (gnu_result_type, gnu_ptr);
1392       }
1393       break;
1394
1395     case Attr_Size:
1396     case Attr_Object_Size:
1397     case Attr_Value_Size:
1398     case Attr_Max_Size_In_Storage_Elements:
1399       gnu_expr = gnu_prefix;
1400
1401       /* Remove NOPs and conversions between original and packable version
1402          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1403          to see if a COMPONENT_REF was involved.  */
1404       while (TREE_CODE (gnu_expr) == NOP_EXPR
1405              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1406                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1407                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1408                     == RECORD_TYPE
1409                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1410                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1411         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1412
1413       gnu_prefix = remove_conversions (gnu_prefix, true);
1414       prefix_unused = true;
1415       gnu_type = TREE_TYPE (gnu_prefix);
1416
1417       /* Replace an unconstrained array type with the type of the underlying
1418          array.  We can't do this with a call to maybe_unconstrained_array
1419          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1420          use the record type that will be used to allocate the object and its
1421          template.  */
1422       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1423         {
1424           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1425           if (attribute != Attr_Max_Size_In_Storage_Elements)
1426             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1427         }
1428
1429       /* If we're looking for the size of a field, return the field size.
1430          Otherwise, if the prefix is an object, or if we're looking for
1431          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1432          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1433       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1434         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1435       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1436                || attribute == Attr_Object_Size
1437                || attribute == Attr_Max_Size_In_Storage_Elements)
1438         {
1439           /* If the prefix is an object of a padded type, the GCC size isn't
1440              relevant to the programmer.  Normally what we want is the RM size,
1441              which was set from the specified size, but if it was not set, we
1442              want the size of the field.  Using the MAX of those two produces
1443              the right result in all cases.  Don't use the size of the field
1444              if it's self-referential, since that's never what's wanted.  */
1445           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1446               && TYPE_IS_PADDING_P (gnu_type)
1447               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1448             {
1449               gnu_result = rm_size (gnu_type);
1450               if (!CONTAINS_PLACEHOLDER_P
1451                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1452                 gnu_result
1453                   = size_binop (MAX_EXPR, gnu_result,
1454                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1455             }
1456           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1457             {
1458               Node_Id gnat_deref = Prefix (gnat_node);
1459               Node_Id gnat_actual_subtype
1460                 = Actual_Designated_Subtype (gnat_deref);
1461               tree gnu_ptr_type
1462                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1463
1464               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1465                   && Present (gnat_actual_subtype))
1466                 {
1467                   tree gnu_actual_obj_type
1468                     = gnat_to_gnu_type (gnat_actual_subtype);
1469                   gnu_type
1470                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1471                                                       gnu_actual_obj_type,
1472                                                       get_identifier ("SIZE"),
1473                                                       false);
1474                 }
1475
1476               gnu_result = TYPE_SIZE (gnu_type);
1477             }
1478           else
1479             gnu_result = TYPE_SIZE (gnu_type);
1480         }
1481       else
1482         gnu_result = rm_size (gnu_type);
1483
1484       /* Deal with a self-referential size by returning the maximum size for
1485          a type and by qualifying the size with the object otherwise.  */
1486       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1487         {
1488           if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1489             gnu_result = max_size (gnu_result, true);
1490           else
1491             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1492         }
1493
1494       /* If the type contains a template, subtract its size.  */
1495       if (TREE_CODE (gnu_type) == RECORD_TYPE
1496           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1497         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1498                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1499
1500       /* For 'Max_Size_In_Storage_Elements, adjust the unit.  */
1501       if (attribute == Attr_Max_Size_In_Storage_Elements)
1502         gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1503
1504       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1505       break;
1506
1507     case Attr_Alignment:
1508       {
1509         unsigned int align;
1510
1511         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1512             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1513           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1514
1515         gnu_type = TREE_TYPE (gnu_prefix);
1516         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1517         prefix_unused = true;
1518
1519         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1520           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1521         else
1522           {
1523             Node_Id gnat_prefix = Prefix (gnat_node);
1524             Entity_Id gnat_type = Etype (gnat_prefix);
1525             unsigned int double_align;
1526             bool is_capped_double, align_clause;
1527
1528             /* If the default alignment of "double" or larger scalar types is
1529                specifically capped and there is an alignment clause neither
1530                on the type nor on the prefix itself, return the cap.  */
1531             if ((double_align = double_float_alignment) > 0)
1532               is_capped_double
1533                 = is_double_float_or_array (gnat_type, &align_clause);
1534             else if ((double_align = double_scalar_alignment) > 0)
1535               is_capped_double
1536                 = is_double_scalar_or_array (gnat_type, &align_clause);
1537             else
1538               is_capped_double = align_clause = false;
1539
1540             if (is_capped_double
1541                 && Nkind (gnat_prefix) == N_Identifier
1542                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1543               align_clause = true;
1544
1545             if (is_capped_double && !align_clause)
1546               align = double_align;
1547             else
1548               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1549           }
1550
1551         gnu_result = size_int (align);
1552       }
1553       break;
1554
1555     case Attr_First:
1556     case Attr_Last:
1557     case Attr_Range_Length:
1558       prefix_unused = true;
1559
1560       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1561         {
1562           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1563
1564           if (attribute == Attr_First)
1565             gnu_result = TYPE_MIN_VALUE (gnu_type);
1566           else if (attribute == Attr_Last)
1567             gnu_result = TYPE_MAX_VALUE (gnu_type);
1568           else
1569             gnu_result
1570               = build_binary_op
1571                 (MAX_EXPR, get_base_type (gnu_result_type),
1572                  build_binary_op
1573                  (PLUS_EXPR, get_base_type (gnu_result_type),
1574                   build_binary_op (MINUS_EXPR,
1575                                    get_base_type (gnu_result_type),
1576                                    convert (gnu_result_type,
1577                                             TYPE_MAX_VALUE (gnu_type)),
1578                                    convert (gnu_result_type,
1579                                             TYPE_MIN_VALUE (gnu_type))),
1580                   convert (gnu_result_type, integer_one_node)),
1581                  convert (gnu_result_type, integer_zero_node));
1582
1583           break;
1584         }
1585
1586       /* ... fall through ... */
1587
1588     case Attr_Length:
1589       {
1590         int Dimension = (Present (Expressions (gnat_node))
1591                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1592                          : 1), i;
1593         struct parm_attr_d *pa = NULL;
1594         Entity_Id gnat_param = Empty;
1595
1596         /* Make sure any implicit dereference gets done.  */
1597         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1598         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1599         /* We treat unconstrained array In parameters specially.  */
1600         if (Nkind (Prefix (gnat_node)) == N_Identifier
1601             && !Is_Constrained (Etype (Prefix (gnat_node)))
1602             && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1603           gnat_param = Entity (Prefix (gnat_node));
1604         gnu_type = TREE_TYPE (gnu_prefix);
1605         prefix_unused = true;
1606         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1607
1608         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1609           {
1610             int ndim;
1611             tree gnu_type_temp;
1612
1613             for (ndim = 1, gnu_type_temp = gnu_type;
1614                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1615                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1616                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1617               ;
1618
1619             Dimension = ndim + 1 - Dimension;
1620           }
1621
1622         for (i = 1; i < Dimension; i++)
1623           gnu_type = TREE_TYPE (gnu_type);
1624
1625         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1626
1627         /* When not optimizing, look up the slot associated with the parameter
1628            and the dimension in the cache and create a new one on failure.  */
1629         if (!optimize && Present (gnat_param))
1630           {
1631             FOR_EACH_VEC_ELT (parm_attr, f_parm_attr_cache, i, pa)
1632               if (pa->id == gnat_param && pa->dim == Dimension)
1633                 break;
1634
1635             if (!pa)
1636               {
1637                 pa = ggc_alloc_cleared_parm_attr_d ();
1638                 pa->id = gnat_param;
1639                 pa->dim = Dimension;
1640                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1641               }
1642           }
1643
1644         /* Return the cached expression or build a new one.  */
1645         if (attribute == Attr_First)
1646           {
1647             if (pa && pa->first)
1648               {
1649                 gnu_result = pa->first;
1650                 break;
1651               }
1652
1653             gnu_result
1654               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1655           }
1656
1657         else if (attribute == Attr_Last)
1658           {
1659             if (pa && pa->last)
1660               {
1661                 gnu_result = pa->last;
1662                 break;
1663               }
1664
1665             gnu_result
1666               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1667           }
1668
1669         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1670           {
1671             if (pa && pa->length)
1672               {
1673                 gnu_result = pa->length;
1674                 break;
1675               }
1676             else
1677               {
1678                 /* We used to compute the length as max (hb - lb + 1, 0),
1679                    which could overflow for some cases of empty arrays, e.g.
1680                    when lb == index_type'first.  We now compute the length as
1681                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1682                    much rarer cases, for extremely large arrays we expect
1683                    never to encounter in practice.  In addition, the former
1684                    computation required the use of potentially constraining
1685                    signed arithmetic while the latter doesn't.  Note that
1686                    the comparison must be done in the original index type,
1687                    to avoid any overflow during the conversion.  */
1688                 tree comp_type = get_base_type (gnu_result_type);
1689                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1690                 tree lb = TYPE_MIN_VALUE (index_type);
1691                 tree hb = TYPE_MAX_VALUE (index_type);
1692                 gnu_result
1693                   = build_binary_op (PLUS_EXPR, comp_type,
1694                                      build_binary_op (MINUS_EXPR,
1695                                                       comp_type,
1696                                                       convert (comp_type, hb),
1697                                                       convert (comp_type, lb)),
1698                                      convert (comp_type, integer_one_node));
1699                 gnu_result
1700                   = build_cond_expr (comp_type,
1701                                      build_binary_op (GE_EXPR,
1702                                                       boolean_type_node,
1703                                                       hb, lb),
1704                                      gnu_result,
1705                                      convert (comp_type, integer_zero_node));
1706               }
1707           }
1708
1709         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1710            handling.  Note that these attributes could not have been used on
1711            an unconstrained array type.  */
1712         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1713
1714         /* Cache the expression we have just computed.  Since we want to do it
1715            at run time, we force the use of a SAVE_EXPR and let the gimplifier
1716            create the temporary in the outermost binding level.  We will make
1717            sure in Subprogram_Body_to_gnu that it is evaluated on all possible
1718            paths by forcing its evaluation on entry of the function.  */
1719         if (pa)
1720           {
1721             gnu_result
1722               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1723             if (attribute == Attr_First)
1724               pa->first = gnu_result;
1725             else if (attribute == Attr_Last)
1726               pa->last = gnu_result;
1727             else
1728               pa->length = gnu_result;
1729           }
1730
1731         /* Set the source location onto the predicate of the condition in the
1732            'Length case but do not do it if the expression is cached to avoid
1733            messing up the debug info.  */
1734         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1735                  && TREE_CODE (gnu_result) == COND_EXPR
1736                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1737           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1738                                        gnat_node);
1739
1740         break;
1741       }
1742
1743     case Attr_Bit_Position:
1744     case Attr_Position:
1745     case Attr_First_Bit:
1746     case Attr_Last_Bit:
1747     case Attr_Bit:
1748       {
1749         HOST_WIDE_INT bitsize;
1750         HOST_WIDE_INT bitpos;
1751         tree gnu_offset;
1752         tree gnu_field_bitpos;
1753         tree gnu_field_offset;
1754         tree gnu_inner;
1755         enum machine_mode mode;
1756         int unsignedp, volatilep;
1757
1758         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1759         gnu_prefix = remove_conversions (gnu_prefix, true);
1760         prefix_unused = true;
1761
1762         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1763            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1764         if (attribute == Attr_Bit
1765             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1766             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1767           {
1768             gnu_result = integer_zero_node;
1769             break;
1770           }
1771
1772         else
1773           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1774                       || (attribute == Attr_Bit_Position
1775                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1776
1777         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1778                              &mode, &unsignedp, &volatilep, false);
1779
1780         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1781           {
1782             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1783             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1784
1785             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1786                  TREE_CODE (gnu_inner) == COMPONENT_REF
1787                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1788                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1789               {
1790                 gnu_field_bitpos
1791                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1792                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1793                 gnu_field_offset
1794                   = size_binop (PLUS_EXPR, gnu_field_offset,
1795                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1796               }
1797           }
1798         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1799           {
1800             gnu_field_bitpos = bit_position (gnu_prefix);
1801             gnu_field_offset = byte_position (gnu_prefix);
1802           }
1803         else
1804           {
1805             gnu_field_bitpos = bitsize_zero_node;
1806             gnu_field_offset = size_zero_node;
1807           }
1808
1809         switch (attribute)
1810           {
1811           case Attr_Position:
1812             gnu_result = gnu_field_offset;
1813             break;
1814
1815           case Attr_First_Bit:
1816           case Attr_Bit:
1817             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1818             break;
1819
1820           case Attr_Last_Bit:
1821             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1822             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1823                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1824             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1825                                      bitsize_one_node);
1826             break;
1827
1828           case Attr_Bit_Position:
1829             gnu_result = gnu_field_bitpos;
1830             break;
1831                 }
1832
1833         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1834            handling.  */
1835         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1836         break;
1837       }
1838
1839     case Attr_Min:
1840     case Attr_Max:
1841       {
1842         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1843         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1844
1845         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1846         gnu_result = build_binary_op (attribute == Attr_Min
1847                                       ? MIN_EXPR : MAX_EXPR,
1848                                       gnu_result_type, gnu_lhs, gnu_rhs);
1849       }
1850       break;
1851
1852     case Attr_Passed_By_Reference:
1853       gnu_result = size_int (default_pass_by_ref (gnu_type)
1854                              || must_pass_by_ref (gnu_type));
1855       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1856       break;
1857
1858     case Attr_Component_Size:
1859       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1860           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1861         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1862
1863       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1864       gnu_type = TREE_TYPE (gnu_prefix);
1865
1866       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1867         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1868
1869       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1870              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1871         gnu_type = TREE_TYPE (gnu_type);
1872
1873       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1874
1875       /* Note this size cannot be self-referential.  */
1876       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1877       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1878       prefix_unused = true;
1879       break;
1880
1881     case Attr_Descriptor_Size:
1882       gnu_type = TREE_TYPE (gnu_prefix);
1883       gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
1884
1885       /* What we want is the offset of the ARRAY field in the record that the
1886         thin pointer designates, but the components have been shifted so this
1887         is actually the opposite of the offset of the BOUNDS field.  */
1888       gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1889       gnu_result = size_binop (MINUS_EXPR, bitsize_zero_node,
1890                                bit_position (TYPE_FIELDS (gnu_type)));
1891       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1892       prefix_unused = true;
1893       break;
1894
1895     case Attr_Null_Parameter:
1896       /* This is just a zero cast to the pointer type for our prefix and
1897          dereferenced.  */
1898       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1899       gnu_result
1900         = build_unary_op (INDIRECT_REF, NULL_TREE,
1901                           convert (build_pointer_type (gnu_result_type),
1902                                    integer_zero_node));
1903       TREE_PRIVATE (gnu_result) = 1;
1904       break;
1905
1906     case Attr_Mechanism_Code:
1907       {
1908         int code;
1909         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1910
1911         prefix_unused = true;
1912         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1913         if (Present (Expressions (gnat_node)))
1914           {
1915             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1916
1917             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1918                  i--, gnat_obj = Next_Formal (gnat_obj))
1919               ;
1920           }
1921
1922         code = Mechanism (gnat_obj);
1923         if (code == Default)
1924           code = ((present_gnu_tree (gnat_obj)
1925                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1926                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1927                             == PARM_DECL)
1928                            && (DECL_BY_COMPONENT_PTR_P
1929                                (get_gnu_tree (gnat_obj))))))
1930                   ? By_Reference : By_Copy);
1931         gnu_result = convert (gnu_result_type, size_int (- code));
1932       }
1933       break;
1934
1935     default:
1936       /* Say we have an unimplemented attribute.  Then set the value to be
1937          returned to be a zero and hope that's something we can convert to
1938          the type of this attribute.  */
1939       post_error ("unimplemented attribute", gnat_node);
1940       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1941       gnu_result = integer_zero_node;
1942       break;
1943     }
1944
1945   /* If this is an attribute where the prefix was unused, force a use of it if
1946      it has a side-effect.  But don't do it if the prefix is just an entity
1947      name.  However, if an access check is needed, we must do it.  See second
1948      example in AARM 11.6(5.e).  */
1949   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1950       && !Is_Entity_Name (Prefix (gnat_node)))
1951     gnu_result = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix,
1952                                        gnu_result);
1953
1954   *gnu_result_type_p = gnu_result_type;
1955   return gnu_result;
1956 }
1957 \f
1958 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1959    to a GCC tree, which is returned.  */
1960
1961 static tree
1962 Case_Statement_to_gnu (Node_Id gnat_node)
1963 {
1964   tree gnu_result, gnu_expr, gnu_label;
1965   Node_Id gnat_when;
1966   location_t end_locus;
1967   bool may_fallthru = false;
1968
1969   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1970   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1971
1972   /*  The range of values in a case statement is determined by the rules in
1973       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1974       of the expression. One exception arises in the case of a simple name that
1975       is parenthesized. This still has the Etype of the name, but since it is
1976       not a name, para 7 does not apply, and we need to go to the base type.
1977       This is the only case where parenthesization affects the dynamic
1978       semantics (i.e. the range of possible values at run time that is covered
1979       by the others alternative).
1980
1981       Another exception is if the subtype of the expression is non-static.  In
1982       that case, we also have to use the base type.  */
1983   if (Paren_Count (Expression (gnat_node)) != 0
1984       || !Is_OK_Static_Subtype (Underlying_Type
1985                                 (Etype (Expression (gnat_node)))))
1986     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1987
1988   /* We build a SWITCH_EXPR that contains the code with interspersed
1989      CASE_LABEL_EXPRs for each label.  */
1990   if (!Sloc_to_locus (Sloc (gnat_node) + UI_To_Int (End_Span (gnat_node)),
1991       &end_locus))
1992     end_locus = input_location;
1993   gnu_label = create_artificial_label (end_locus);
1994   start_stmt_group ();
1995
1996   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1997        Present (gnat_when);
1998        gnat_when = Next_Non_Pragma (gnat_when))
1999     {
2000       bool choices_added_p = false;
2001       Node_Id gnat_choice;
2002
2003       /* First compile all the different case choices for the current WHEN
2004          alternative.  */
2005       for (gnat_choice = First (Discrete_Choices (gnat_when));
2006            Present (gnat_choice); gnat_choice = Next (gnat_choice))
2007         {
2008           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2009
2010           switch (Nkind (gnat_choice))
2011             {
2012             case N_Range:
2013               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2014               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2015               break;
2016
2017             case N_Subtype_Indication:
2018               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2019                                                 (Constraint (gnat_choice))));
2020               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2021                                                   (Constraint (gnat_choice))));
2022               break;
2023
2024             case N_Identifier:
2025             case N_Expanded_Name:
2026               /* This represents either a subtype range or a static value of
2027                  some kind; Ekind says which.  */
2028               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2029                 {
2030                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2031
2032                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
2033                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
2034                   break;
2035                 }
2036
2037               /* ... fall through ... */
2038
2039             case N_Character_Literal:
2040             case N_Integer_Literal:
2041               gnu_low = gnat_to_gnu (gnat_choice);
2042               break;
2043
2044             case N_Others_Choice:
2045               break;
2046
2047             default:
2048               gcc_unreachable ();
2049             }
2050
2051           /* If the case value is a subtype that raises Constraint_Error at
2052              run time because of a wrong bound, then gnu_low or gnu_high is
2053              not translated into an INTEGER_CST.  In such a case, we need
2054              to ensure that the when statement is not added in the tree,
2055              otherwise it will crash the gimplifier.  */
2056           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2057               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2058             {
2059               add_stmt_with_node (build_case_label
2060                                   (gnu_low, gnu_high,
2061                                    create_artificial_label (input_location)),
2062                                   gnat_choice);
2063               choices_added_p = true;
2064             }
2065         }
2066
2067       /* Push a binding level here in case variables are declared as we want
2068          them to be local to this set of statements instead of to the block
2069          containing the Case statement.  */
2070       if (choices_added_p)
2071         {
2072           tree group = build_stmt_group (Statements (gnat_when), true);
2073           bool group_may_fallthru = block_may_fallthru (group);
2074           add_stmt (group);
2075           if (group_may_fallthru)
2076             {
2077               tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2078               SET_EXPR_LOCATION (stmt, end_locus);
2079               add_stmt (stmt);
2080               may_fallthru = true;
2081             }
2082         }
2083     }
2084
2085   /* Now emit a definition of the label the cases branch to, if any.  */
2086   if (may_fallthru)
2087     add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2088   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2089                        end_stmt_group (), NULL_TREE);
2090
2091   return gnu_result;
2092 }
2093 \f
2094 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2095    false, or the maximum value if MAX is true, of TYPE.  */
2096
2097 static bool
2098 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2099 {
2100   tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2101
2102   if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2103     return true;
2104
2105   if (TREE_CODE (val) == NOP_EXPR)
2106     val = (max
2107            ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2108            : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2109
2110   if (TREE_CODE (val) != INTEGER_CST)
2111     return true;
2112
2113   return tree_int_cst_equal (val, min_or_max_val) == 1;
2114 }
2115
2116 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2117    If REVERSE is true, minimum value is taken as maximum value.  */
2118
2119 static inline bool
2120 can_equal_min_val_p (tree val, tree type, bool reverse)
2121 {
2122   return can_equal_min_or_max_val_p (val, type, reverse);
2123 }
2124
2125 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2126    If REVERSE is true, maximum value is taken as minimum value.  */
2127
2128 static inline bool
2129 can_equal_max_val_p (tree val, tree type, bool reverse)
2130 {
2131   return can_equal_min_or_max_val_p (val, type, !reverse);
2132 }
2133
2134 /* Return true if VAL1 can be lower than VAL2.  */
2135
2136 static bool
2137 can_be_lower_p (tree val1, tree val2)
2138 {
2139   if (TREE_CODE (val1) == NOP_EXPR)
2140     val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2141
2142   if (TREE_CODE (val1) != INTEGER_CST)
2143     return true;
2144
2145   if (TREE_CODE (val2) == NOP_EXPR)
2146     val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2147
2148   if (TREE_CODE (val2) != INTEGER_CST)
2149     return true;
2150
2151   return tree_int_cst_lt (val1, val2);
2152 }
2153
2154 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2155    to a GCC tree, which is returned.  */
2156
2157 static tree
2158 Loop_Statement_to_gnu (Node_Id gnat_node)
2159 {
2160   const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2161   tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2162                                NULL_TREE, NULL_TREE, NULL_TREE);
2163   tree gnu_loop_label = create_artificial_label (input_location);
2164   tree gnu_loop_var = NULL_TREE, gnu_cond_expr = NULL_TREE;
2165   tree gnu_result;
2166
2167   /* Set location information for statement and end label.  */
2168   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2169   Sloc_to_locus (Sloc (End_Label (gnat_node)),
2170                  &DECL_SOURCE_LOCATION (gnu_loop_label));
2171   LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2172
2173   /* Save the end label of this LOOP_STMT in a stack so that a corresponding
2174      N_Exit_Statement can find it.  */
2175   VEC_safe_push (tree, gc, gnu_loop_label_stack, gnu_loop_label);
2176
2177   /* Set the condition under which the loop must keep going.
2178      For the case "LOOP .... END LOOP;" the condition is always true.  */
2179   if (No (gnat_iter_scheme))
2180     ;
2181
2182   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2183   else if (Present (Condition (gnat_iter_scheme)))
2184     LOOP_STMT_COND (gnu_loop_stmt)
2185       = gnat_to_gnu (Condition (gnat_iter_scheme));
2186
2187   /* Otherwise we have an iteration scheme and the condition is given by the
2188      bounds of the subtype of the iteration variable.  */
2189   else
2190     {
2191       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2192       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2193       Entity_Id gnat_type = Etype (gnat_loop_var);
2194       tree gnu_type = get_unpadded_type (gnat_type);
2195       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2196       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2197       tree gnu_base_type = get_base_type (gnu_type);
2198       tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2199       tree gnu_first, gnu_last;
2200       enum tree_code update_code, test_code, shift_code;
2201       bool reverse = Reverse_Present (gnat_loop_spec), fallback = false;
2202
2203       /* We must disable modulo reduction for the iteration variable, if any,
2204          in order for the loop comparison to be effective.  */
2205       if (reverse)
2206         {
2207           gnu_first = gnu_high;
2208           gnu_last = gnu_low;
2209           update_code = MINUS_NOMOD_EXPR;
2210           test_code = GE_EXPR;
2211           shift_code = PLUS_NOMOD_EXPR;
2212         }
2213       else
2214         {
2215           gnu_first = gnu_low;
2216           gnu_last = gnu_high;
2217           update_code = PLUS_NOMOD_EXPR;
2218           test_code = LE_EXPR;
2219           shift_code = MINUS_NOMOD_EXPR;
2220         }
2221
2222       /* We use two different strategies to translate the loop, depending on
2223          whether optimization is enabled.
2224
2225          If it is, we try to generate the canonical form of loop expected by
2226          the loop optimizer, which is the do-while form:
2227
2228              ENTRY_COND
2229            loop:
2230              TOP_UPDATE
2231              BODY
2232              BOTTOM_COND
2233              GOTO loop
2234
2235          This makes it possible to bypass loop header copying and to turn the
2236          BOTTOM_COND into an inequality test.  This should catch (almost) all
2237          loops with constant starting point.  If we cannot, we try to generate
2238          the default form, which is:
2239
2240            loop:
2241              TOP_COND
2242              BODY
2243              BOTTOM_UPDATE
2244              GOTO loop
2245
2246          It will be rotated during loop header copying and an entry test added
2247          to yield the do-while form.  This should catch (almost) all loops with
2248          constant ending point.  If we cannot, we generate the fallback form:
2249
2250              ENTRY_COND
2251            loop:
2252              BODY
2253              BOTTOM_COND
2254              BOTTOM_UPDATE
2255              GOTO loop
2256
2257          which works in all cases but for which loop header copying will copy
2258          the BOTTOM_COND, thus adding a third conditional branch.
2259
2260          If optimization is disabled, loop header copying doesn't come into
2261          play and we try to generate the loop forms with the less conditional
2262          branches directly.  First, the default form, it should catch (almost)
2263          all loops with constant ending point.  Then, if we cannot, we try to
2264          generate the shifted form:
2265
2266            loop:
2267              TOP_COND
2268              TOP_UPDATE
2269              BODY
2270              GOTO loop
2271
2272          which should catch loops with constant starting point.  Otherwise, if
2273          we cannot, we generate the fallback form.  */
2274
2275       if (optimize)
2276         {
2277           /* We can use the do-while form if GNU_FIRST-1 doesn't overflow.  */
2278           if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2279             {
2280               gnu_first = build_binary_op (shift_code, gnu_base_type,
2281                                            gnu_first, gnu_one_node);
2282               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2283               LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2284             }
2285
2286           /* Otherwise, we can use the default form if GNU_LAST+1 doesn't.  */
2287           else if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2288             ;
2289
2290           /* Otherwise, use the fallback form.  */
2291           else
2292             fallback = true;
2293         }
2294       else
2295         {
2296           /* We can use the default form if GNU_LAST+1 doesn't overflow.  */
2297           if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2298             ;
2299
2300           /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2301              GNU_LAST-1 does.  */
2302           else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2303                    && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2304             {
2305               gnu_first = build_binary_op (shift_code, gnu_base_type,
2306                                            gnu_first, gnu_one_node);
2307               gnu_last = build_binary_op (shift_code, gnu_base_type,
2308                                           gnu_last, gnu_one_node);
2309               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2310             }
2311
2312           /* Otherwise, use the fallback form.  */
2313           else
2314             fallback = true;
2315         }
2316
2317       if (fallback)
2318         LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2319
2320       /* If we use the BOTTOM_COND, we can turn the test into an inequality
2321          test but we may have to add ENTRY_COND to protect the empty loop.  */
2322       if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2323         {
2324           test_code = NE_EXPR;
2325           if (can_be_lower_p (gnu_high, gnu_low))
2326             {
2327               gnu_cond_expr
2328                 = build3 (COND_EXPR, void_type_node,
2329                           build_binary_op (LE_EXPR, boolean_type_node,
2330                                            gnu_low, gnu_high),
2331                           NULL_TREE, alloc_stmt_list ());
2332               set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2333             }
2334         }
2335
2336       /* Open a new nesting level that will surround the loop to declare the
2337          iteration variable.  */
2338       start_stmt_group ();
2339       gnat_pushlevel ();
2340
2341       /* Declare the iteration variable and set it to its initial value.  */
2342       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2343       if (DECL_BY_REF_P (gnu_loop_var))
2344         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2345
2346       /* Do all the arithmetics in the base type.  */
2347       gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2348
2349       /* Set either the top or bottom exit condition.  */
2350       LOOP_STMT_COND (gnu_loop_stmt)
2351         = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2352                            gnu_last);
2353
2354       /* Set either the top or bottom update statement and give it the source
2355          location of the iteration for better coverage info.  */
2356       LOOP_STMT_UPDATE (gnu_loop_stmt)
2357         = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2358                            build_binary_op (update_code, gnu_base_type,
2359                                             gnu_loop_var, gnu_one_node));
2360       set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
2361                                    gnat_iter_scheme);
2362     }
2363
2364   /* If the loop was named, have the name point to this loop.  In this case,
2365      the association is not a DECL node, but the end label of the loop.  */
2366   if (Present (Identifier (gnat_node)))
2367     save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2368
2369   /* Make the loop body into its own block, so any allocated storage will be
2370      released every iteration.  This is needed for stack allocation.  */
2371   LOOP_STMT_BODY (gnu_loop_stmt)
2372     = build_stmt_group (Statements (gnat_node), true);
2373   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2374
2375   /* If we declared a variable, then we are in a statement group for that
2376      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
2377   if (gnu_loop_var)
2378     {
2379       add_stmt (gnu_loop_stmt);
2380       gnat_poplevel ();
2381       gnu_loop_stmt = end_stmt_group ();
2382     }
2383
2384   /* If we have an outer COND_EXPR, that's our result and this loop is its
2385      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2386   if (gnu_cond_expr)
2387     {
2388       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2389       gnu_result = gnu_cond_expr;
2390       recalculate_side_effects (gnu_cond_expr);
2391     }
2392   else
2393     gnu_result = gnu_loop_stmt;
2394
2395   VEC_pop (tree, gnu_loop_label_stack);
2396
2397   return gnu_result;
2398 }
2399 \f
2400 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2401    handler for the current function.  */
2402
2403 /* This is implemented by issuing a call to the appropriate VMS specific
2404    builtin.  To avoid having VMS specific sections in the global gigi decls
2405    array, we maintain the decls of interest here.  We can't declare them
2406    inside the function because we must mark them never to be GC'd, which we
2407    can only do at the global level.  */
2408
2409 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2410 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2411
2412 static void
2413 establish_gnat_vms_condition_handler (void)
2414 {
2415   tree establish_stmt;
2416
2417   /* Elaborate the required decls on the first call.  Check on the decl for
2418      the gnat condition handler to decide, as this is one we create so we are
2419      sure that it will be non null on subsequent calls.  The builtin decl is
2420      looked up so remains null on targets where it is not implemented yet.  */
2421   if (gnat_vms_condition_handler_decl == NULL_TREE)
2422     {
2423       vms_builtin_establish_handler_decl
2424         = builtin_decl_for
2425           (get_identifier ("__builtin_establish_vms_condition_handler"));
2426
2427       gnat_vms_condition_handler_decl
2428         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2429                                NULL_TREE,
2430                                build_function_type_list (boolean_type_node,
2431                                                          ptr_void_type_node,
2432                                                          ptr_void_type_node,
2433                                                          NULL_TREE),
2434                                NULL_TREE, false, true, true, true, NULL,
2435                                Empty);
2436
2437       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2438       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2439     }
2440
2441   /* Do nothing if the establish builtin is not available, which might happen
2442      on targets where the facility is not implemented.  */
2443   if (vms_builtin_establish_handler_decl == NULL_TREE)
2444     return;
2445
2446   establish_stmt
2447     = build_call_1_expr (vms_builtin_establish_handler_decl,
2448                          build_unary_op
2449                          (ADDR_EXPR, NULL_TREE,
2450                           gnat_vms_condition_handler_decl));
2451
2452   add_stmt (establish_stmt);
2453 }
2454
2455 /* Similar, but for RETURN_EXPR.  If RET_VAL is non-null, build a RETURN_EXPR
2456    around the assignment of RET_VAL to RET_OBJ.  Otherwise just build a bare
2457    RETURN_EXPR around RESULT_OBJ, which may be null in this case.  */
2458
2459 static tree
2460 build_return_expr (tree ret_obj, tree ret_val)
2461 {
2462   tree result_expr;
2463
2464   if (ret_val)
2465     {
2466       /* The gimplifier explicitly enforces the following invariant:
2467
2468               RETURN_EXPR
2469                   |
2470               MODIFY_EXPR
2471               /        \
2472              /          \
2473          RET_OBJ        ...
2474
2475          As a consequence, type consistency dictates that we use the type
2476          of the RET_OBJ as the operation type.  */
2477       tree operation_type = TREE_TYPE (ret_obj);
2478
2479       /* Convert the right operand to the operation type.  Note that it's the
2480          same transformation as in the MODIFY_EXPR case of build_binary_op,
2481          with the assumption that the type cannot involve a placeholder.  */
2482       if (operation_type != TREE_TYPE (ret_val))
2483         ret_val = convert (operation_type, ret_val);
2484
2485       result_expr = build2 (MODIFY_EXPR, void_type_node, ret_obj, ret_val);
2486     }
2487   else
2488     result_expr = ret_obj;
2489
2490   return build1 (RETURN_EXPR, void_type_node, result_expr);
2491 }
2492
2493 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
2494    and the GNAT node GNAT_SUBPROG.  */
2495
2496 static void
2497 build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
2498 {
2499   tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
2500   tree gnu_subprog_param, gnu_stub_param, gnu_param;
2501   tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
2502   VEC(tree,gc) *gnu_param_vec = NULL;
2503
2504   gnu_subprog_type = TREE_TYPE (gnu_subprog);
2505
2506   /* Initialize the information structure for the function.  */
2507   allocate_struct_function (gnu_stub_decl, false);
2508   set_cfun (NULL);
2509
2510   begin_subprog_body (gnu_stub_decl);
2511
2512   start_stmt_group ();
2513   gnat_pushlevel ();
2514
2515   /* Loop over the parameters of the stub and translate any of them
2516      passed by descriptor into a by reference one.  */
2517   for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
2518        gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog);
2519        gnu_stub_param;
2520        gnu_stub_param = TREE_CHAIN (gnu_stub_param),
2521        gnu_subprog_param = TREE_CHAIN (gnu_subprog_param))
2522     {
2523       if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
2524         {
2525           gcc_assert (DECL_BY_REF_P (gnu_subprog_param));
2526           gnu_param
2527             = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param),
2528                                       gnu_stub_param,
2529                                       DECL_PARM_ALT_TYPE (gnu_stub_param),
2530                                       DECL_BY_DOUBLE_REF_P (gnu_subprog_param),
2531                                       gnat_subprog);
2532         }
2533       else
2534         gnu_param = gnu_stub_param;
2535
2536       VEC_safe_push (tree, gc, gnu_param_vec, gnu_param);
2537     }
2538
2539   /* Invoke the internal subprogram.  */
2540   gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
2541                              gnu_subprog);
2542   gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type),
2543                                      gnu_subprog_addr, gnu_param_vec);
2544
2545   /* Propagate the return value, if any.  */
2546   if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
2547     add_stmt (gnu_subprog_call);
2548   else
2549     add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl),
2550                                  gnu_subprog_call));
2551
2552   gnat_poplevel ();
2553   end_subprog_body (end_stmt_group ());
2554 }
2555 \f
2556 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
2557    don't return anything.  */
2558
2559 static void
2560 Subprogram_Body_to_gnu (Node_Id gnat_node)
2561 {
2562   /* Defining identifier of a parameter to the subprogram.  */
2563   Entity_Id gnat_param;
2564   /* The defining identifier for the subprogram body. Note that if a
2565      specification has appeared before for this body, then the identifier
2566      occurring in that specification will also be a defining identifier and all
2567      the calls to this subprogram will point to that specification.  */
2568   Entity_Id gnat_subprog_id
2569     = (Present (Corresponding_Spec (gnat_node))
2570        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2571   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
2572   tree gnu_subprog_decl;
2573   /* Its RESULT_DECL node.  */
2574   tree gnu_result_decl;
2575   /* Its FUNCTION_TYPE node.  */
2576   tree gnu_subprog_type;
2577   /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any.  */
2578   tree gnu_cico_list;
2579   /* The entry in the CI_CO_LIST that represents a function return, if any.  */
2580   tree gnu_return_var_elmt = NULL_TREE;
2581   tree gnu_result;
2582   struct language_function *gnu_subprog_language;
2583   VEC(parm_attr,gc) *cache;
2584
2585   /* If this is a generic object or if it has been eliminated,
2586      ignore it.  */
2587   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2588       || Ekind (gnat_subprog_id) == E_Generic_Function
2589       || Is_Eliminated (gnat_subprog_id))
2590     return;
2591
2592   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
2593      the already-elaborated tree node.  However, if this subprogram had its
2594      elaboration deferred, we will already have made a tree node for it.  So
2595      treat it as not being defined in that case.  Such a subprogram cannot
2596      have an address clause or a freeze node, so this test is safe, though it
2597      does disable some otherwise-useful error checking.  */
2598   gnu_subprog_decl
2599     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2600                           Acts_As_Spec (gnat_node)
2601                           && !present_gnu_tree (gnat_subprog_id));
2602   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
2603   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2604   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2605   if (gnu_cico_list)
2606     gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list);
2607
2608   /* If the function returns by invisible reference, make it explicit in the
2609      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.
2610      Handle the explicit case here and the copy-in/copy-out case below.  */
2611   if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt)
2612     {
2613       TREE_TYPE (gnu_result_decl)
2614         = build_reference_type (TREE_TYPE (gnu_result_decl));
2615       relayout_decl (gnu_result_decl);
2616     }
2617
2618   /* Set the line number in the decl to correspond to that of the body so that
2619      the line number notes are written correctly.  */
2620   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
2621
2622   /* Initialize the information structure for the function.  */
2623   allocate_struct_function (gnu_subprog_decl, false);
2624   gnu_subprog_language = ggc_alloc_cleared_language_function ();
2625   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
2626   set_cfun (NULL);
2627
2628   begin_subprog_body (gnu_subprog_decl);
2629
2630   /* If there are In Out or Out parameters, we need to ensure that the return
2631      statement properly copies them out.  We do this by making a new block and
2632      converting any return into a goto to a label at the end of the block.  */
2633   if (gnu_cico_list)
2634     {
2635       tree gnu_return_var = NULL_TREE;
2636
2637       VEC_safe_push (tree, gc, gnu_return_label_stack,
2638                      create_artificial_label (input_location));
2639
2640       start_stmt_group ();
2641       gnat_pushlevel ();
2642
2643       /* If this is a function with In Out or Out parameters, we also need a
2644          variable for the return value to be placed.  */
2645       if (gnu_return_var_elmt)
2646         {
2647           tree gnu_return_type
2648             = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
2649
2650           /* If the function returns by invisible reference, make it
2651              explicit in the function body.  See gnat_to_gnu_entity,
2652              E_Subprogram_Type case.  */
2653           if (TREE_ADDRESSABLE (gnu_subprog_type))
2654             gnu_return_type = build_reference_type (gnu_return_type);
2655
2656           gnu_return_var
2657             = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
2658                                gnu_return_type, NULL_TREE, false, false,
2659                                false, false, NULL, gnat_subprog_id);
2660           TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
2661         }
2662
2663       VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var);
2664
2665       /* See whether there are parameters for which we don't have a GCC tree
2666          yet.  These must be Out parameters.  Make a VAR_DECL for them and
2667          put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
2668          We can match up the entries because TYPE_CI_CO_LIST is in the order
2669          of the parameters.  */
2670       for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2671            Present (gnat_param);
2672            gnat_param = Next_Formal_With_Extras (gnat_param))
2673         if (!present_gnu_tree (gnat_param))
2674           {
2675             tree gnu_cico_entry = gnu_cico_list;
2676
2677             /* Skip any entries that have been already filled in; they must
2678                correspond to In Out parameters.  */
2679             while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
2680               gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
2681
2682             /* Do any needed references for padded types.  */
2683             TREE_VALUE (gnu_cico_entry)
2684               = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)),
2685                          gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2686           }
2687     }
2688   else
2689     VEC_safe_push (tree, gc, gnu_return_label_stack, NULL_TREE);
2690
2691   /* Get a tree corresponding to the code for the subprogram.  */
2692   start_stmt_group ();
2693   gnat_pushlevel ();
2694
2695   /* On VMS, establish our condition handler to possibly turn a condition into
2696      the corresponding exception if the subprogram has a foreign convention or
2697      is exported.
2698
2699      To ensure proper execution of local finalizations on condition instances,
2700      we must turn a condition into the corresponding exception even if there
2701      is no applicable Ada handler, and need at least one condition handler per
2702      possible call chain involving GNAT code.  OTOH, establishing the handler
2703      has a cost so we want to minimize the number of subprograms into which
2704      this happens.  The foreign or exported condition is expected to satisfy
2705      all the constraints.  */
2706   if (TARGET_ABI_OPEN_VMS
2707       && (Has_Foreign_Convention (gnat_subprog_id)
2708           || Is_Exported (gnat_subprog_id)))
2709     establish_gnat_vms_condition_handler ();
2710
2711   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
2712
2713   /* Generate the code of the subprogram itself.  A return statement will be
2714      present and any Out parameters will be handled there.  */
2715   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
2716   gnat_poplevel ();
2717   gnu_result = end_stmt_group ();
2718
2719   /* If we populated the parameter attributes cache, we need to make sure that
2720      the cached expressions are evaluated on all the possible paths leading to
2721      their uses.  So we force their evaluation on entry of the function.  */
2722   cache = gnu_subprog_language->parm_attr_cache;
2723   if (cache)
2724     {
2725       struct parm_attr_d *pa;
2726       int i;
2727
2728       start_stmt_group ();
2729
2730       FOR_EACH_VEC_ELT (parm_attr, cache, i, pa)
2731         {
2732           if (pa->first)
2733             add_stmt_with_node_force (pa->first, gnat_node);
2734           if (pa->last)
2735             add_stmt_with_node_force (pa->last, gnat_node);
2736           if (pa->length)
2737             add_stmt_with_node_force (pa->length, gnat_node);
2738         }
2739
2740       add_stmt (gnu_result);
2741       gnu_result = end_stmt_group ();
2742
2743       gnu_subprog_language->parm_attr_cache = NULL;
2744     }
2745
2746   /* If we are dealing with a return from an Ada procedure with parameters
2747      passed by copy-in/copy-out, we need to return a record containing the
2748      final values of these parameters.  If the list contains only one entry,
2749      return just that entry though.
2750
2751      For a full description of the copy-in/copy-out parameter mechanism, see
2752      the part of the gnat_to_gnu_entity routine dealing with the translation
2753      of subprograms.
2754
2755      We need to make a block that contains the definition of that label and
2756      the copying of the return value.  It first contains the function, then
2757      the label and copy statement.  */
2758   if (gnu_cico_list)
2759     {
2760       tree gnu_retval;
2761
2762       add_stmt (gnu_result);
2763       add_stmt (build1 (LABEL_EXPR, void_type_node,
2764                         VEC_last (tree, gnu_return_label_stack)));
2765
2766       if (list_length (gnu_cico_list) == 1)
2767         gnu_retval = TREE_VALUE (gnu_cico_list);
2768       else
2769         gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
2770                                                   gnu_cico_list);
2771
2772       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
2773                           End_Label (Handled_Statement_Sequence (gnat_node)));
2774       gnat_poplevel ();
2775       gnu_result = end_stmt_group ();
2776     }
2777
2778   VEC_pop (tree, gnu_return_label_stack);
2779
2780   /* Attempt setting the end_locus of our GCC body tree, typically a
2781      BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
2782      declaration tree.  */
2783   set_end_locus_from_node (gnu_result, gnat_node);
2784   set_end_locus_from_node (gnu_subprog_decl, gnat_node);
2785
2786   end_subprog_body (gnu_result);
2787
2788   /* Finally annotate the parameters and disconnect the trees for parameters
2789      that we have turned into variables since they are now unusable.  */
2790   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2791        Present (gnat_param);
2792        gnat_param = Next_Formal_With_Extras (gnat_param))
2793     {
2794       tree gnu_param = get_gnu_tree (gnat_param);
2795       bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
2796
2797       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
2798                        DECL_BY_REF_P (gnu_param),
2799                        !is_var_decl && DECL_BY_DOUBLE_REF_P (gnu_param));
2800
2801       if (is_var_decl)
2802         save_gnu_tree (gnat_param, NULL_TREE, false);
2803     }
2804
2805   if (gnu_return_var_elmt)
2806     TREE_VALUE (gnu_return_var_elmt) = void_type_node;
2807
2808   /* If there is a stub associated with the function, build it now.  */
2809   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2810     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2811
2812   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2813 }
2814 \f
2815 /* Create a temporary variable with PREFIX and TYPE, and return it.  */
2816
2817 static tree
2818 create_temporary (const char *prefix, tree type)
2819 {
2820   tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
2821                                    type, NULL_TREE, false, false, false, false,
2822                                    NULL, Empty);
2823   DECL_ARTIFICIAL (gnu_temp) = 1;
2824   DECL_IGNORED_P (gnu_temp) = 1;
2825
2826   return gnu_temp;
2827 }
2828
2829 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
2830    Put the initialization statement into GNU_INIT_STMT and annotate it with
2831    the SLOC of GNAT_NODE.  Return the temporary variable.  */
2832
2833 static tree
2834 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
2835                        Node_Id gnat_node)
2836 {
2837   tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
2838
2839   *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
2840   set_expr_location_from_node (*gnu_init_stmt, gnat_node);
2841
2842   return gnu_temp;
2843 }
2844
2845 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2846    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2847    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2848    If GNU_TARGET is non-null, this must be a function call on the RHS of a
2849    N_Assignment_Statement and the result is to be placed into that object.  */
2850
2851 static tree
2852 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2853 {
2854   const bool function_call = (Nkind (gnat_node) == N_Function_Call);
2855   const bool returning_value = (function_call && !gnu_target);
2856   /* The GCC node corresponding to the GNAT subprogram name.  This can either
2857      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2858      or an indirect reference expression (an INDIRECT_REF node) pointing to a
2859      subprogram.  */
2860   tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
2861   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2862   tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
2863   /* The return type of the FUNCTION_TYPE.  */
2864   tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
2865   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
2866   VEC(tree,gc) *gnu_actual_vec = NULL;
2867   tree gnu_name_list = NULL_TREE;
2868   tree gnu_stmt_list = NULL_TREE;
2869   tree gnu_after_list = NULL_TREE;
2870   tree gnu_retval = NULL_TREE;
2871   tree gnu_call, gnu_result;
2872   bool went_into_elab_proc = false;
2873   bool pushed_binding_level = false;
2874   Entity_Id gnat_formal;
2875   Node_Id gnat_actual;
2876
2877   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2878
2879   /* If we are calling a stubbed function, raise Program_Error, but Elaborate
2880      all our args first.  */
2881   if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
2882     {
2883       tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
2884                                          gnat_node, N_Raise_Program_Error);
2885
2886       for (gnat_actual = First_Actual (gnat_node);
2887            Present (gnat_actual);
2888            gnat_actual = Next_Actual (gnat_actual))
2889         add_stmt (gnat_to_gnu (gnat_actual));
2890
2891       if (returning_value)
2892         {
2893           *gnu_result_type_p = gnu_result_type;
2894           return build1 (NULL_EXPR, gnu_result_type, call_expr);
2895         }
2896
2897       return call_expr;
2898     }
2899
2900   /* The only way we can be making a call via an access type is if Name is an
2901      explicit dereference.  In that case, get the list of formal args from the
2902      type the access type is pointing to.  Otherwise, get the formals from the
2903      entity being called.  */
2904   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2905     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2906   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2907     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2908     gnat_formal = Empty;
2909   else
2910     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2911
2912   /* The lifetime of the temporaries created for the call ends right after the
2913      return value is copied, so we can give them the scope of the elaboration
2914      routine at top level.  */
2915   if (!current_function_decl)
2916     {
2917       current_function_decl = get_elaboration_procedure ();
2918       went_into_elab_proc = true;
2919     }
2920
2921   /* First, create the temporary for the return value if we need it: for a
2922      variable-sized return type if there is no target or if this is slice,
2923      because the gimplifier doesn't support these cases; or for a function
2924      with copy-in/copy-out parameters if there is no target, because we'll
2925      need to preserve the return value before copying back the parameters.
2926      This must be done before we push a new binding level around the call
2927      as we will pop it before copying the return value.  */
2928   if (function_call
2929       && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
2930            && (!gnu_target || TREE_CODE (gnu_target) == ARRAY_RANGE_REF))
2931           || (!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))))
2932     gnu_retval = create_temporary ("R", gnu_result_type);
2933
2934   /* Create the list of the actual parameters as GCC expects it, namely a
2935      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
2936      is an expression and the TREE_PURPOSE field is null.  But skip Out
2937      parameters not passed by reference and that need not be copied in.  */
2938   for (gnat_actual = First_Actual (gnat_node);
2939        Present (gnat_actual);
2940        gnat_formal = Next_Formal_With_Extras (gnat_formal),
2941        gnat_actual = Next_Actual (gnat_actual))
2942     {
2943       tree gnu_formal = present_gnu_tree (gnat_formal)
2944                         ? get_gnu_tree (gnat_formal) : NULL_TREE;
2945       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2946       /* In the Out or In Out case, we must suppress conversions that yield
2947          an lvalue but can nevertheless cause the creation of a temporary,
2948          because we need the real object in this case, either to pass its
2949          address if it's passed by reference or as target of the back copy
2950          done after the call if it uses the copy-in/copy-out mechanism.
2951          We do it in the In case too, except for an unchecked conversion
2952          because it alone can cause the actual to be misaligned and the
2953          addressability test is applied to the real object.  */
2954       bool suppress_type_conversion
2955         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2956             && Ekind (gnat_formal) != E_In_Parameter)
2957            || (Nkind (gnat_actual) == N_Type_Conversion
2958                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2959       Node_Id gnat_name = suppress_type_conversion
2960                           ? Expression (gnat_actual) : gnat_actual;
2961       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2962       tree gnu_actual;
2963
2964       /* If it's possible we may need to use this expression twice, make sure
2965          that any side-effects are handled via SAVE_EXPRs; likewise if we need
2966          to force side-effects before the call.
2967          ??? This is more conservative than we need since we don't need to do
2968          this for pass-by-ref with no conversion.  */
2969       if (Ekind (gnat_formal) != E_In_Parameter)
2970         gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
2971
2972       /* If we are passing a non-addressable parameter by reference, pass the
2973          address of a copy.  In the Out or In Out case, set up to copy back
2974          out after the call.  */
2975       if (gnu_formal
2976           && (DECL_BY_REF_P (gnu_formal)
2977               || (TREE_CODE (gnu_formal) == PARM_DECL
2978                   && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2979                       || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2980           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2981           && !addressable_p (gnu_name, gnu_name_type))
2982         {
2983           bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
2984           tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
2985
2986           /* Do not issue warnings for CONSTRUCTORs since this is not a copy
2987              but sort of an instantiation for them.  */
2988           if (TREE_CODE (gnu_name) == CONSTRUCTOR)
2989             ;
2990
2991           /* If the type is passed by reference, a copy is not allowed.  */
2992           else if (TREE_ADDRESSABLE (gnu_formal_type))
2993             post_error ("misaligned actual cannot be passed by reference",
2994                         gnat_actual);
2995
2996           /* For users of Starlet we issue a warning because the interface
2997              apparently assumes that by-ref parameters outlive the procedure
2998              invocation.  The code still will not work as intended, but we
2999              cannot do much better since low-level parts of the back-end
3000              would allocate temporaries at will because of the misalignment
3001              if we did not do so here.  */
3002           else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
3003             {
3004               post_error
3005                 ("?possible violation of implicit assumption", gnat_actual);
3006               post_error_ne
3007                 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
3008                  Entity (Name (gnat_node)));
3009               post_error_ne ("?because of misalignment of &", gnat_actual,
3010                              gnat_formal);
3011             }
3012
3013           /* If the actual type of the object is already the nominal type,
3014              we have nothing to do, except if the size is self-referential
3015              in which case we'll remove the unpadding below.  */
3016           if (TREE_TYPE (gnu_name) == gnu_name_type
3017               && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
3018             ;
3019
3020           /* Otherwise remove the unpadding from all the objects.  */
3021           else if (TREE_CODE (gnu_name) == COMPONENT_REF
3022                    && TYPE_IS_PADDING_P
3023                       (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
3024             gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
3025
3026           /* Otherwise convert to the nominal type of the object if needed.
3027              There are several cases in which we need to make the temporary
3028              using this type instead of the actual type of the object when
3029              they are distinct, because the expectations of the callee would
3030              otherwise not be met:
3031                - if it's a justified modular type,
3032                - if the actual type is a smaller form of it,
3033                - if it's a smaller form of the actual type.  */
3034           else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
3035                     && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
3036                         || smaller_form_type_p (TREE_TYPE (gnu_name),
3037                                                 gnu_name_type)))
3038                    || (INTEGRAL_TYPE_P (gnu_name_type)
3039                        && smaller_form_type_p (gnu_name_type,
3040                                                TREE_TYPE (gnu_name))))
3041             gnu_name = convert (gnu_name_type, gnu_name);
3042
3043           /* If this is an In Out or Out parameter and we're returning a value,
3044              we need to create a temporary for the return value because we must
3045              preserve it before copying back at the very end.  */
3046           if (!in_param && returning_value && !gnu_retval)
3047             gnu_retval = create_temporary ("R", gnu_result_type);
3048
3049           /* If we haven't pushed a binding level, push a new one.  This will
3050              narrow the lifetime of the temporary we are about to make as much
3051              as possible.  The drawback is that we'd need to create a temporary
3052              for the return value, if any (see comment before the loop).  So do
3053              it only when this temporary was already created just above.  */
3054           if (!pushed_binding_level && !(in_param && returning_value))
3055             {
3056               start_stmt_group ();
3057               gnat_pushlevel ();
3058               pushed_binding_level = true;
3059             }
3060
3061           /* Create an explicit temporary holding the copy.  */
3062           gnu_temp
3063             = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
3064
3065           /* But initialize it on the fly like for an implicit temporary as
3066              we aren't necessarily having a statement list.  */
3067           gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
3068                                           gnu_temp);
3069
3070           /* Set up to move the copy back to the original if needed.  */
3071           if (!in_param)
3072             {
3073               gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
3074                                           gnu_temp);
3075               set_expr_location_from_node (gnu_stmt, gnat_node);
3076               append_to_statement_list (gnu_stmt, &gnu_after_list);
3077             }
3078         }
3079
3080       /* Start from the real object and build the actual.  */
3081       gnu_actual = gnu_name;
3082
3083       /* If this was a procedure call, we may not have removed any padding.
3084          So do it here for the part we will use as an input, if any.  */
3085       if (Ekind (gnat_formal) != E_Out_Parameter
3086           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
3087         gnu_actual
3088           = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
3089
3090       /* Put back the conversion we suppressed above in the computation of the
3091          real object.  And even if we didn't suppress any conversion there, we
3092          may have suppressed a conversion to the Etype of the actual earlier,
3093          since the parent is a procedure call, so put it back here.  */
3094       if (suppress_type_conversion
3095           && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
3096         gnu_actual
3097           = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
3098                                gnu_actual, No_Truncation (gnat_actual));
3099       else
3100         gnu_actual
3101           = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
3102
3103       /* Make sure that the actual is in range of the formal's type.  */
3104       if (Ekind (gnat_formal) != E_Out_Parameter
3105           && Do_Range_Check (gnat_actual))
3106         gnu_actual
3107           = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
3108
3109       /* Unless this is an In parameter, we must remove any justified modular
3110          building from GNU_NAME to get an lvalue.  */
3111       if (Ekind (gnat_formal) != E_In_Parameter
3112           && TREE_CODE (gnu_name) == CONSTRUCTOR
3113           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
3114           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
3115         gnu_name
3116           = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
3117
3118       /* If we have not saved a GCC object for the formal, it means it is an
3119          Out parameter not passed by reference and that need not be copied in.
3120          Otherwise, first see if the parameter is passed by reference.  */
3121       if (gnu_formal
3122           && TREE_CODE (gnu_formal) == PARM_DECL
3123           && DECL_BY_REF_P (gnu_formal))
3124         {
3125           if (Ekind (gnat_formal) != E_In_Parameter)
3126             {
3127               /* In Out or Out parameters passed by reference don't use the
3128                  copy-in/copy-out mechanism so the address of the real object
3129                  must be passed to the function.  */
3130               gnu_actual = gnu_name;
3131
3132               /* If we have a padded type, be sure we've removed padding.  */
3133               if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
3134                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
3135                                       gnu_actual);
3136
3137               /* If we have the constructed subtype of an aliased object
3138                  with an unconstrained nominal subtype, the type of the
3139                  actual includes the template, although it is formally
3140                  constrained.  So we need to convert it back to the real
3141                  constructed subtype to retrieve the constrained part
3142                  and takes its address.  */
3143               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
3144                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
3145                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
3146                   && Is_Array_Type (Etype (gnat_actual)))
3147                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
3148                                       gnu_actual);
3149             }
3150
3151           /* There is no need to convert the actual to the formal's type before
3152              taking its address.  The only exception is for unconstrained array
3153              types because of the way we build fat pointers.  */
3154           if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
3155             {
3156               /* Put back a view conversion for In Out or Out parameters.  */
3157               if (Ekind (gnat_formal) != E_In_Parameter)
3158                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
3159                                       gnu_actual);
3160               gnu_actual = convert (gnu_formal_type, gnu_actual);
3161             }
3162
3163           /* The symmetry of the paths to the type of an entity is broken here
3164              since arguments don't know that they will be passed by ref.  */
3165           gnu_formal_type = TREE_TYPE (gnu_formal);
3166
3167           if (DECL_BY_DOUBLE_REF_P (gnu_formal))
3168             gnu_actual
3169               = build_unary_op (ADDR_EXPR, TREE_TYPE (gnu_formal_type),
3170                                 gnu_actual);
3171
3172           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
3173         }
3174       else if (gnu_formal
3175                && TREE_CODE (gnu_formal) == PARM_DECL
3176                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
3177         {
3178           gnu_formal_type = TREE_TYPE (gnu_formal);
3179           gnu_actual = maybe_implicit_deref (gnu_actual);
3180           gnu_actual = maybe_unconstrained_array (gnu_actual);
3181
3182           if (TYPE_IS_PADDING_P (gnu_formal_type))
3183             {
3184               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
3185               gnu_actual = convert (gnu_formal_type, gnu_actual);
3186             }
3187
3188           /* Take the address of the object and convert to the proper pointer
3189              type.  We'd like to actually compute the address of the beginning
3190              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
3191              possibility that the ARRAY_REF might return a constant and we'd be
3192              getting the wrong address.  Neither approach is exactly correct,
3193              but this is the most likely to work in all cases.  */
3194           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
3195         }
3196       else if (gnu_formal
3197                && TREE_CODE (gnu_formal) == PARM_DECL
3198                && DECL_BY_DESCRIPTOR_P (gnu_formal))
3199         {
3200           gnu_actual = convert (gnu_formal_type, gnu_actual);
3201
3202           /* If this is 'Null_Parameter, pass a zero descriptor.  */
3203           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
3204                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
3205               && TREE_PRIVATE (gnu_actual))
3206             gnu_actual
3207               = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
3208           else
3209             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
3210                                          fill_vms_descriptor
3211                                          (TREE_TYPE (TREE_TYPE (gnu_formal)),
3212                                           gnu_actual, gnat_actual));
3213         }
3214       else
3215         {
3216           tree gnu_size;
3217
3218           if (Ekind (gnat_formal) != E_In_Parameter)
3219             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
3220
3221           if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
3222             {
3223               /* Make sure side-effects are evaluated before the call.  */
3224               if (TREE_SIDE_EFFECTS (gnu_name))
3225                 append_to_statement_list (gnu_name, &gnu_stmt_list);
3226               continue;
3227             }
3228
3229           gnu_actual = convert (gnu_formal_type, gnu_actual);
3230
3231           /* If this is 'Null_Parameter, pass a zero even though we are
3232              dereferencing it.  */
3233           if (TREE_CODE (gnu_actual) == INDIRECT_REF
3234               && TREE_PRIVATE (gnu_actual)
3235               && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
3236               && TREE_CODE (gnu_size) == INTEGER_CST
3237               && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
3238             gnu_actual
3239               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
3240                                    convert (gnat_type_for_size
3241                                             (TREE_INT_CST_LOW (gnu_size), 1),
3242                                             integer_zero_node),
3243                                    false);
3244           else
3245             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
3246         }
3247
3248       VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual);
3249     }
3250
3251   gnu_call
3252     = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
3253   set_expr_location_from_node (gnu_call, gnat_node);
3254
3255   /* If we have created a temporary for the return value, initialize it.  */
3256   if (gnu_retval)
3257     {
3258       tree gnu_stmt
3259         = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
3260       set_expr_location_from_node (gnu_stmt, gnat_node);
3261       append_to_statement_list (gnu_stmt, &gnu_stmt_list);
3262       gnu_call = gnu_retval;
3263     }
3264
3265   /* If this is a subprogram with copy-in/copy-out parameters, we need to
3266      unpack the valued returned from the function into the In Out or Out
3267      parameters.  We deal with the function return (if this is an Ada
3268      function) below.  */
3269   if (TYPE_CI_CO_LIST (gnu_subprog_type))
3270     {
3271       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
3272          copy-out parameters.  */
3273       tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3274       const int length = list_length (gnu_cico_list);
3275
3276       /* The call sequence must contain one and only one call, even though the
3277          function is pure.  Save the result into a temporary if needed.  */
3278       if (length > 1)
3279         {
3280           if (!gnu_retval)
3281             {
3282               tree gnu_stmt;
3283               /* If we haven't pushed a binding level, push a new one.  This
3284                  will narrow the lifetime of the temporary we are about to
3285                  make as much as possible.  */
3286               if (!pushed_binding_level)
3287                 {
3288                   start_stmt_group ();
3289                   gnat_pushlevel ();
3290                   pushed_binding_level = true;
3291                 }
3292               gnu_call
3293                 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
3294               append_to_statement_list (gnu_stmt, &gnu_stmt_list);
3295             }
3296
3297           gnu_name_list = nreverse (gnu_name_list);
3298         }
3299
3300       /* The first entry is for the actual return value if this is a
3301          function, so skip it.  */
3302       if (TREE_VALUE (gnu_cico_list) == void_type_node)
3303         gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3304
3305       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3306         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
3307       else
3308         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
3309
3310       for (gnat_actual = First_Actual (gnat_node);
3311            Present (gnat_actual);
3312            gnat_formal = Next_Formal_With_Extras (gnat_formal),
3313            gnat_actual = Next_Actual (gnat_actual))
3314         /* If we are dealing with a copy-in/copy-out parameter, we must
3315            retrieve its value from the record returned in the call.  */
3316         if (!(present_gnu_tree (gnat_formal)
3317               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3318               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
3319                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3320                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
3321                            || (DECL_BY_DESCRIPTOR_P
3322                                (get_gnu_tree (gnat_formal))))))))
3323             && Ekind (gnat_formal) != E_In_Parameter)
3324           {
3325             /* Get the value to assign to this Out or In Out parameter.  It is
3326                either the result of the function if there is only a single such
3327                parameter or the appropriate field from the record returned.  */
3328             tree gnu_result
3329               = length == 1
3330                 ? gnu_call
3331                 : build_component_ref (gnu_call, NULL_TREE,
3332                                        TREE_PURPOSE (gnu_cico_list), false);
3333
3334             /* If the actual is a conversion, get the inner expression, which
3335                will be the real destination, and convert the result to the
3336                type of the actual parameter.  */
3337             tree gnu_actual
3338               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3339
3340             /* If the result is a padded type, remove the padding.  */
3341             if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3342               gnu_result
3343                 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
3344                            gnu_result);
3345
3346             /* If the actual is a type conversion, the real target object is
3347                denoted by the inner Expression and we need to convert the
3348                result to the associated type.
3349                We also need to convert our gnu assignment target to this type
3350                if the corresponding GNU_NAME was constructed from the GNAT
3351                conversion node and not from the inner Expression.  */
3352             if (Nkind (gnat_actual) == N_Type_Conversion)
3353               {
3354                 gnu_result
3355                   = convert_with_check
3356                     (Etype (Expression (gnat_actual)), gnu_result,
3357                      Do_Overflow_Check (gnat_actual),
3358                      Do_Range_Check (Expression (gnat_actual)),
3359                      Float_Truncate (gnat_actual), gnat_actual);
3360
3361                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
3362                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
3363               }
3364
3365             /* Unchecked conversions as actuals for Out parameters are not
3366                allowed in user code because they are not variables, but do
3367                occur in front-end expansions.  The associated GNU_NAME is
3368                always obtained from the inner expression in such cases.  */
3369             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
3370               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
3371                                               gnu_result,
3372                                               No_Truncation (gnat_actual));
3373             else
3374               {
3375                 if (Do_Range_Check (gnat_actual))
3376                   gnu_result
3377                     = emit_range_check (gnu_result, Etype (gnat_actual),
3378                                         gnat_actual);
3379
3380                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
3381                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
3382                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
3383               }
3384
3385             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3386                                           gnu_actual, gnu_result);
3387             set_expr_location_from_node (gnu_result, gnat_node);
3388             append_to_statement_list (gnu_result, &gnu_stmt_list);
3389             gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3390             gnu_name_list = TREE_CHAIN (gnu_name_list);
3391           }
3392     }
3393
3394   /* If this is a function call, the result is the call expression unless a
3395      target is specified, in which case we copy the result into the target
3396      and return the assignment statement.  */
3397   if (function_call)
3398     {
3399       /* If this is a function with copy-in/copy-out parameters, extract the
3400          return value from it and update the return type.  */
3401       if (TYPE_CI_CO_LIST (gnu_subprog_type))
3402         {
3403           tree gnu_elmt = value_member (void_type_node,
3404                                         TYPE_CI_CO_LIST (gnu_subprog_type));
3405           gnu_call = build_component_ref (gnu_call, NULL_TREE,
3406                                           TREE_PURPOSE (gnu_elmt), false);
3407           gnu_result_type = TREE_TYPE (gnu_call);
3408         }
3409
3410       /* If the function returns an unconstrained array or by direct reference,
3411          we have to dereference the pointer.  */
3412       if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
3413           || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
3414         gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
3415
3416       if (gnu_target)
3417         {
3418           Node_Id gnat_parent = Parent (gnat_node);
3419           enum tree_code op_code;
3420
3421           /* If range check is needed, emit code to generate it.  */
3422           if (Do_Range_Check (gnat_node))
3423             gnu_call
3424               = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
3425                                   gnat_parent);
3426
3427           /* ??? If the return type has variable size, then force the return
3428              slot optimization as we would not be able to create a temporary.
3429              Likewise if it was unconstrained as we would copy too much data.
3430              That's what has been done historically.  */
3431           if (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
3432               || (TYPE_IS_PADDING_P (gnu_result_type)
3433                   && CONTAINS_PLACEHOLDER_P
3434                      (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type))))))
3435             op_code = INIT_EXPR;
3436           else
3437             op_code = MODIFY_EXPR;
3438
3439           gnu_call
3440             = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
3441           set_expr_location_from_node (gnu_call, gnat_parent);
3442           append_to_statement_list (gnu_call, &gnu_stmt_list);
3443         }
3444       else
3445         *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
3446     }
3447
3448   /* Otherwise, if this is a procedure call statement without copy-in/copy-out
3449      parameters, the result is just the call statement.  */
3450   else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
3451     append_to_statement_list (gnu_call, &gnu_stmt_list);
3452
3453   /* Finally, add the copy back statements, if any.  */
3454   append_to_statement_list (gnu_after_list, &gnu_stmt_list);
3455
3456   if (went_into_elab_proc)
3457     current_function_decl = NULL_TREE;
3458
3459   /* If we have pushed a binding level, pop it and finish up the enclosing
3460      statement group.  */
3461   if (pushed_binding_level)
3462     {
3463       add_stmt (gnu_stmt_list);
3464       gnat_poplevel ();
3465       gnu_result = end_stmt_group ();
3466     }
3467
3468   /* Otherwise, retrieve the statement list, if any.  */
3469   else if (gnu_stmt_list)
3470     gnu_result = gnu_stmt_list;
3471
3472   /* Otherwise, just return the call expression.  */
3473   else
3474     return gnu_call;
3475
3476   /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.  */
3477   if (returning_value)
3478     gnu_result
3479       = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
3480
3481   return gnu_result;
3482 }
3483 \f
3484 /* Subroutine of gnat_to_gnu to translate gnat_node, an
3485    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
3486
3487 static tree
3488 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
3489 {
3490   tree gnu_jmpsave_decl = NULL_TREE;
3491   tree gnu_jmpbuf_decl = NULL_TREE;
3492   /* If just annotating, ignore all EH and cleanups.  */
3493   bool gcc_zcx = (!type_annotate_only
3494                   && Present (Exception_Handlers (gnat_node))
3495                   && Exception_Mechanism == Back_End_Exceptions);
3496   bool setjmp_longjmp
3497     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
3498        && Exception_Mechanism == Setjmp_Longjmp);
3499   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
3500   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
3501   tree gnu_inner_block; /* The statement(s) for the block itself.  */
3502   tree gnu_result;
3503   tree gnu_expr;
3504   Node_Id gnat_temp;
3505
3506   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
3507      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
3508      add_cleanup, and when we leave the binding, end_stmt_group will create
3509      the TRY_FINALLY_EXPR.
3510
3511      ??? The region level calls down there have been specifically put in place
3512      for a ZCX context and currently the order in which things are emitted
3513      (region/handlers) is different from the SJLJ case. Instead of putting
3514      other calls with different conditions at other places for the SJLJ case,
3515      it seems cleaner to reorder things for the SJLJ case and generalize the
3516      condition to make it not ZCX specific.
3517
3518      If there are any exceptions or cleanup processing involved, we need an
3519      outer statement group (for Setjmp_Longjmp) and binding level.  */
3520   if (binding_for_block)
3521     {
3522       start_stmt_group ();
3523       gnat_pushlevel ();
3524     }
3525
3526   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
3527      area for address of previous buffer.  Do this first since we need to have
3528      the setjmp buf known for any decls in this block.  */
3529   if (setjmp_longjmp)
3530     {
3531       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
3532                                           NULL_TREE, jmpbuf_ptr_type,
3533                                           build_call_0_expr (get_jmpbuf_decl),
3534                                           false, false, false, false,
3535                                           NULL, gnat_node);
3536       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
3537
3538       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
3539          because of the unstructured form of EH used by setjmp_longjmp, there
3540          might be forward edges going to __builtin_setjmp receivers on which
3541          it is uninitialized, although they will never be actually taken.  */
3542       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
3543       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
3544                                          NULL_TREE, jmpbuf_type, NULL_TREE,
3545                                          false, false, false, false,
3546                                          NULL, gnat_node);
3547       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
3548
3549       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
3550
3551       /* When we exit this block, restore the saved value.  */
3552       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
3553                    End_Label (gnat_node));
3554     }
3555
3556   /* If we are to call a function when exiting this block, add a cleanup
3557      to the binding level we made above.  Note that add_cleanup is FIFO
3558      so we must register this cleanup after the EH cleanup just above.  */
3559   if (at_end)
3560     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
3561                  End_Label (gnat_node));
3562
3563   /* Now build the tree for the declarations and statements inside this block.
3564      If this is SJLJ, set our jmp_buf as the current buffer.  */
3565   start_stmt_group ();
3566
3567   if (setjmp_longjmp)
3568     add_stmt (build_call_1_expr (set_jmpbuf_decl,
3569                                  build_unary_op (ADDR_EXPR, NULL_TREE,
3570                                                  gnu_jmpbuf_decl)));
3571
3572   if (Present (First_Real_Statement (gnat_node)))
3573     process_decls (Statements (gnat_node), Empty,
3574                    First_Real_Statement (gnat_node), true, true);
3575
3576   /* Generate code for each statement in the block.  */
3577   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3578                     ? First_Real_Statement (gnat_node)
3579                     : First (Statements (gnat_node)));
3580        Present (gnat_temp); gnat_temp = Next (gnat_temp))
3581     add_stmt (gnat_to_gnu (gnat_temp));
3582   gnu_inner_block = end_stmt_group ();
3583
3584   /* Now generate code for the two exception models, if either is relevant for
3585      this block.  */
3586   if (setjmp_longjmp)
3587     {
3588       tree *gnu_else_ptr = 0;
3589       tree gnu_handler;
3590
3591       /* Make a binding level for the exception handling declarations and code
3592          and set up gnu_except_ptr_stack for the handlers to use.  */
3593       start_stmt_group ();
3594       gnat_pushlevel ();
3595
3596       VEC_safe_push (tree, gc, gnu_except_ptr_stack,
3597                      create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
3598                                       build_pointer_type (except_type_node),
3599                                       build_call_0_expr (get_excptr_decl),
3600                                       false, false, false, false,
3601                                       NULL, gnat_node));
3602
3603       /* Generate code for each handler. The N_Exception_Handler case does the
3604          real work and returns a COND_EXPR for each handler, which we chain
3605          together here.  */
3606       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3607            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
3608         {
3609           gnu_expr = gnat_to_gnu (gnat_temp);
3610
3611           /* If this is the first one, set it as the outer one. Otherwise,
3612              point the "else" part of the previous handler to us. Then point
3613              to our "else" part.  */
3614           if (!gnu_else_ptr)
3615             add_stmt (gnu_expr);
3616           else
3617             *gnu_else_ptr = gnu_expr;
3618
3619           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3620         }
3621
3622       /* If none of the exception handlers did anything, re-raise but do not
3623          defer abortion.  */
3624       gnu_expr = build_call_1_expr (raise_nodefer_decl,
3625                                     VEC_last (tree, gnu_except_ptr_stack));
3626       set_expr_location_from_node
3627         (gnu_expr,
3628          Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
3629
3630       if (gnu_else_ptr)
3631         *gnu_else_ptr = gnu_expr;
3632       else
3633         add_stmt (gnu_expr);
3634
3635       /* End the binding level dedicated to the exception handlers and get the
3636          whole statement group.  */
3637       VEC_pop (tree, gnu_except_ptr_stack);
3638       gnat_poplevel ();
3639       gnu_handler = end_stmt_group ();
3640
3641       /* If the setjmp returns 1, we restore our incoming longjmp value and
3642          then check the handlers.  */
3643       start_stmt_group ();
3644       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
3645                                              gnu_jmpsave_decl),
3646                           gnat_node);
3647       add_stmt (gnu_handler);
3648       gnu_handler = end_stmt_group ();
3649
3650       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
3651       gnu_result = build3 (COND_EXPR, void_type_node,
3652                            (build_call_1_expr
3653                             (setjmp_decl,
3654                              build_unary_op (ADDR_EXPR, NULL_TREE,
3655                                              gnu_jmpbuf_decl))),
3656                            gnu_handler, gnu_inner_block);
3657     }
3658   else if (gcc_zcx)
3659     {
3660       tree gnu_handlers;
3661
3662       /* First make a block containing the handlers.  */
3663       start_stmt_group ();
3664       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3665            Present (gnat_temp);
3666            gnat_temp = Next_Non_Pragma (gnat_temp))
3667         add_stmt (gnat_to_gnu (gnat_temp));
3668       gnu_handlers = end_stmt_group ();
3669
3670       /* Now make the TRY_CATCH_EXPR for the block.  */
3671       gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
3672                            gnu_inner_block, gnu_handlers);
3673     }
3674   else
3675     gnu_result = gnu_inner_block;
3676
3677   /* Now close our outer block, if we had to make one.  */
3678   if (binding_for_block)
3679     {
3680       add_stmt (gnu_result);
3681       gnat_poplevel ();
3682       gnu_result = end_stmt_group ();
3683     }
3684
3685   return gnu_result;
3686 }
3687 \f
3688 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3689    to a GCC tree, which is returned.  This is the variant for Setjmp_Longjmp
3690    exception handling.  */
3691
3692 static tree
3693 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
3694 {
3695   /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
3696      an "if" statement to select the proper exceptions.  For "Others", exclude
3697      exceptions where Handled_By_Others is nonzero unless the All_Others flag
3698      is set. For "Non-ada", accept an exception if "Lang" is 'V'.  */
3699   tree gnu_choice = boolean_false_node;
3700   tree gnu_body = build_stmt_group (Statements (gnat_node), false);
3701   Node_Id gnat_temp;
3702
3703   for (gnat_temp = First (Exception_Choices (gnat_node));
3704        gnat_temp; gnat_temp = Next (gnat_temp))
3705     {
3706       tree this_choice;
3707
3708       if (Nkind (gnat_temp) == N_Others_Choice)
3709         {
3710           if (All_Others (gnat_temp))
3711             this_choice = boolean_true_node;
3712           else
3713             this_choice
3714               = build_binary_op
3715                 (EQ_EXPR, boolean_type_node,
3716                  convert
3717                  (integer_type_node,
3718                   build_component_ref
3719                   (build_unary_op
3720                    (INDIRECT_REF, NULL_TREE,
3721                     VEC_last (tree, gnu_except_ptr_stack)),
3722                    get_identifier ("not_handled_by_others"), NULL_TREE,
3723                    false)),
3724                  integer_zero_node);
3725         }
3726
3727       else if (Nkind (gnat_temp) == N_Identifier
3728                || Nkind (gnat_temp) == N_Expanded_Name)
3729         {
3730           Entity_Id gnat_ex_id = Entity (gnat_temp);
3731           tree gnu_expr;
3732
3733           /* Exception may be a renaming. Recover original exception which is
3734              the one elaborated and registered.  */
3735           if (Present (Renamed_Object (gnat_ex_id)))
3736             gnat_ex_id = Renamed_Object (gnat_ex_id);
3737
3738           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3739
3740           this_choice
3741             = build_binary_op
3742               (EQ_EXPR, boolean_type_node,
3743                VEC_last (tree, gnu_except_ptr_stack),
3744                convert (TREE_TYPE (VEC_last (tree, gnu_except_ptr_stack)),
3745                         build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3746
3747           /* If this is the distinguished exception "Non_Ada_Error" (and we are
3748              in VMS mode), also allow a non-Ada exception (a VMS condition) t
3749              match.  */
3750           if (Is_Non_Ada_Error (Entity (gnat_temp)))
3751             {
3752               tree gnu_comp
3753                 = build_component_ref
3754                   (build_unary_op (INDIRECT_REF, NULL_TREE,
3755                                    VEC_last (tree, gnu_except_ptr_stack)),
3756                    get_identifier ("lang"), NULL_TREE, false);
3757
3758               this_choice
3759                 = build_binary_op
3760                   (TRUTH_ORIF_EXPR, boolean_type_node,
3761                    build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp,
3762                                     build_int_cst (TREE_TYPE (gnu_comp), 'V')),
3763                    this_choice);
3764             }
3765         }
3766       else
3767         gcc_unreachable ();
3768
3769       gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
3770                                     gnu_choice, this_choice);
3771     }
3772
3773   return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
3774 }
3775 \f
3776 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3777    to a GCC tree, which is returned.  This is the variant for ZCX.  */
3778
3779 static tree
3780 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
3781 {
3782   tree gnu_etypes_list = NULL_TREE;
3783   tree gnu_expr;
3784   tree gnu_etype;
3785   tree gnu_current_exc_ptr;
3786   tree prev_gnu_incoming_exc_ptr;
3787   Node_Id gnat_temp;
3788
3789   /* We build a TREE_LIST of nodes representing what exception types this
3790      handler can catch, with special cases for others and all others cases.
3791
3792      Each exception type is actually identified by a pointer to the exception
3793      id, or to a dummy object for "others" and "all others".  */
3794   for (gnat_temp = First (Exception_Choices (gnat_node));
3795        gnat_temp; gnat_temp = Next (gnat_temp))
3796     {
3797       if (Nkind (gnat_temp) == N_Others_Choice)
3798         {
3799           tree gnu_expr
3800             = All_Others (gnat_temp) ? all_others_decl : others_decl;
3801
3802           gnu_etype
3803             = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3804         }
3805       else if (Nkind (gnat_temp) == N_Identifier
3806                || Nkind (gnat_temp) == N_Expanded_Name)
3807         {
3808           Entity_Id gnat_ex_id = Entity (gnat_temp);
3809
3810           /* Exception may be a renaming. Recover original exception which is
3811              the one elaborated and registered.  */
3812           if (Present (Renamed_Object (gnat_ex_id)))
3813             gnat_ex_id = Renamed_Object (gnat_ex_id);
3814
3815           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3816           gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3817
3818           /* The Non_Ada_Error case for VMS exceptions is handled
3819              by the personality routine.  */
3820         }
3821       else
3822         gcc_unreachable ();
3823
3824       /* The GCC interface expects NULL to be passed for catch all handlers, so
3825          it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
3826          is integer_zero_node.  It would not work, however, because GCC's
3827          notion of "catch all" is stronger than our notion of "others".  Until
3828          we correctly use the cleanup interface as well, doing that would
3829          prevent the "all others" handlers from being seen, because nothing
3830          can be caught beyond a catch all from GCC's point of view.  */
3831       gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3832     }
3833
3834   start_stmt_group ();
3835   gnat_pushlevel ();
3836
3837   /* Expand a call to the begin_handler hook at the beginning of the handler,
3838      and arrange for a call to the end_handler hook to occur on every possible
3839      exit path.
3840
3841      The hooks expect a pointer to the low level occurrence. This is required
3842      for our stack management scheme because a raise inside the handler pushes
3843      a new occurrence on top of the stack, which means that this top does not
3844      necessarily match the occurrence this handler was dealing with.
3845
3846      __builtin_eh_pointer references the exception occurrence being
3847      propagated. Upon handler entry, this is the exception for which the
3848      handler is triggered. This might not be the case upon handler exit,
3849      however, as we might have a new occurrence propagated by the handler's
3850      body, and the end_handler hook called as a cleanup in this context.
3851
3852      We use a local variable to retrieve the incoming value at handler entry
3853      time, and reuse it to feed the end_handler hook's argument at exit.  */
3854
3855   gnu_current_exc_ptr
3856     = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
3857                        1, integer_zero_node);
3858   prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
3859   gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3860                                           ptr_type_node, gnu_current_exc_ptr,
3861                                           false, false, false, false,
3862                                           NULL, gnat_node);
3863
3864   add_stmt_with_node (build_call_1_expr (begin_handler_decl,
3865                                          gnu_incoming_exc_ptr),
3866                       gnat_node);
3867   /* ??? We don't seem to have an End_Label at hand to set the location.  */
3868   add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
3869                Empty);
3870   add_stmt_list (Statements (gnat_node));
3871   gnat_poplevel ();
3872
3873   gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
3874
3875   return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
3876                  end_stmt_group ());
3877 }
3878 \f
3879 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
3880
3881 static void
3882 Compilation_Unit_to_gnu (Node_Id gnat_node)
3883 {
3884   const Node_Id gnat_unit = Unit (gnat_node);
3885   const bool body_p = (Nkind (gnat_unit) == N_Package_Body
3886                        || Nkind (gnat_unit) == N_Subprogram_Body);
3887   const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
3888   /* Make the decl for the elaboration procedure.  */
3889   tree gnu_elab_proc_decl
3890     = create_subprog_decl
3891       (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
3892        NULL_TREE, void_ftype, NULL_TREE, false, true, false, true, NULL,
3893        gnat_unit);
3894   struct elab_info *info;
3895
3896   VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl);
3897   DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
3898
3899   /* Initialize the information structure for the function.  */
3900   allocate_struct_function (gnu_elab_proc_decl, false);
3901   set_cfun (NULL);
3902
3903   current_function_decl = NULL_TREE;
3904
3905   start_stmt_group ();
3906   gnat_pushlevel ();
3907
3908   /* For a body, first process the spec if there is one.  */
3909   if (Nkind (gnat_unit) == N_Package_Body
3910       || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
3911     add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
3912
3913   if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3914     {
3915       elaborate_all_entities (gnat_node);
3916
3917       if (Nkind (gnat_unit) == N_Subprogram_Declaration
3918           || Nkind (gnat_unit) == N_Generic_Package_Declaration
3919           || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
3920         return;
3921     }
3922
3923   process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
3924                  true, true);
3925   add_stmt (gnat_to_gnu (gnat_unit));
3926
3927   /* If we can inline, generate code for all the inlined subprograms.  */
3928   if (optimize)
3929     {
3930       Entity_Id gnat_entity;
3931
3932       for (gnat_entity = First_Inlined_Subprogram (gnat_node);
3933            Present (gnat_entity);
3934            gnat_entity = Next_Inlined_Subprogram (gnat_entity))
3935         {
3936           Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
3937
3938           if (Nkind (gnat_body) != N_Subprogram_Body)
3939             {
3940               /* ??? This really should always be present.  */
3941               if (No (Corresponding_Body (gnat_body)))
3942                 continue;
3943               gnat_body
3944                 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
3945             }
3946
3947           if (Present (gnat_body))
3948             {
3949               /* Define the entity first so we set DECL_EXTERNAL.  */
3950               gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
3951               add_stmt (gnat_to_gnu (gnat_body));
3952             }
3953         }
3954     }
3955
3956   /* Process any pragmas and actions following the unit.  */
3957   add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
3958   add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
3959   finalize_from_with_types ();
3960
3961   /* Save away what we've made so far and record this potential elaboration
3962      procedure.  */
3963   info = ggc_alloc_elab_info ();
3964   set_current_block_context (gnu_elab_proc_decl);
3965   gnat_poplevel ();
3966   DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
3967
3968   set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
3969
3970   info->next = elab_info_list;
3971   info->elab_proc = gnu_elab_proc_decl;
3972   info->gnat_node = gnat_node;
3973   elab_info_list = info;
3974
3975   /* Generate elaboration code for this unit, if necessary, and say whether
3976      we did or not.  */
3977   VEC_pop (tree, gnu_elab_proc_stack);
3978
3979   /* Invalidate the global renaming pointers.  This is necessary because
3980      stabilization of the renamed entities may create SAVE_EXPRs which
3981      have been tied to a specific elaboration routine just above.  */
3982   invalidate_global_renaming_pointers ();
3983 }
3984 \f
3985 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
3986    as gigi is concerned.  This is used to avoid conversions on the LHS.  */
3987
3988 static bool
3989 unchecked_conversion_nop (Node_Id gnat_node)
3990 {
3991   Entity_Id from_type, to_type;
3992
3993   /* The conversion must be on the LHS of an assignment or an actual parameter
3994      of a call.  Otherwise, even if the conversion was essentially a no-op, it
3995      could de facto ensure type consistency and this should be preserved.  */
3996   if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement
3997         && Name (Parent (gnat_node)) == gnat_node)
3998       && !((Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
3999             || Nkind (Parent (gnat_node)) == N_Function_Call)
4000            && Name (Parent (gnat_node)) != gnat_node))
4001     return false;
4002
4003   from_type = Etype (Expression (gnat_node));
4004
4005   /* We're interested in artificial conversions generated by the front-end
4006      to make private types explicit, e.g. in Expand_Assign_Array.  */
4007   if (!Is_Private_Type (from_type))
4008     return false;
4009
4010   from_type = Underlying_Type (from_type);
4011   to_type = Etype (gnat_node);
4012
4013   /* The direct conversion to the underlying type is a no-op.  */
4014   if (to_type == from_type)
4015     return true;
4016
4017   /* For an array subtype, the conversion to the PAT is a no-op.  */
4018   if (Ekind (from_type) == E_Array_Subtype
4019       && to_type == Packed_Array_Type (from_type))
4020     return true;
4021
4022   /* For a record subtype, the conversion to the type is a no-op.  */
4023   if (Ekind (from_type) == E_Record_Subtype
4024       && to_type == Etype (from_type))
4025     return true;
4026
4027   return false;
4028 }
4029
4030 /* This function is the driver of the GNAT to GCC tree transformation process.
4031    It is the entry point of the tree transformer.  GNAT_NODE is the root of
4032    some GNAT tree.  Return the root of the corresponding GCC tree.  If this
4033    is an expression, return the GCC equivalent of the expression.  If this
4034    is a statement, return the statement or add it to the current statement
4035    group, in which case anything returned is to be interpreted as occurring
4036    after anything added.  */
4037
4038 tree
4039 gnat_to_gnu (Node_Id gnat_node)
4040 {
4041   const Node_Kind kind = Nkind (gnat_node);
4042   bool went_into_elab_proc = false;
4043   tree gnu_result = error_mark_node; /* Default to no value.  */
4044   tree gnu_result_type = void_type_node;
4045   tree gnu_expr, gnu_lhs, gnu_rhs;
4046   Node_Id gnat_temp;
4047
4048   /* Save node number for error message and set location information.  */
4049   error_gnat_node = gnat_node;
4050   Sloc_to_locus (Sloc (gnat_node), &input_location);
4051
4052   /* If this node is a statement and we are only annotating types, return an
4053      empty statement list.  */
4054   if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
4055     return alloc_stmt_list ();
4056
4057   /* If this node is a non-static subexpression and we are only annotating
4058      types, make this into a NULL_EXPR.  */
4059   if (type_annotate_only
4060       && IN (kind, N_Subexpr)
4061       && kind != N_Identifier
4062       && !Compile_Time_Known_Value (gnat_node))
4063     return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
4064                    build_call_raise (CE_Range_Check_Failed, gnat_node,
4065                                      N_Raise_Constraint_Error));
4066
4067   if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
4068        && kind != N_Null_Statement)
4069       || kind == N_Procedure_Call_Statement
4070       || kind == N_Label
4071       || kind == N_Implicit_Label_Declaration
4072       || kind == N_Handled_Sequence_Of_Statements
4073       || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
4074     {
4075       tree current_elab_proc = get_elaboration_procedure ();
4076
4077       /* If this is a statement and we are at top level, it must be part of
4078          the elaboration procedure, so mark us as being in that procedure.  */
4079       if (!current_function_decl)
4080         {
4081           current_function_decl = current_elab_proc;
4082           went_into_elab_proc = true;
4083         }
4084
4085       /* If we are in the elaboration procedure, check if we are violating a
4086          No_Elaboration_Code restriction by having a statement there.  Don't
4087          check for a possible No_Elaboration_Code restriction violation on
4088          N_Handled_Sequence_Of_Statements, as we want to signal an error on
4089          every nested real statement instead.  This also avoids triggering
4090          spurious errors on dummy (empty) sequences created by the front-end
4091          for package bodies in some cases.  */
4092       if (current_function_decl == current_elab_proc
4093           && kind != N_Handled_Sequence_Of_Statements)
4094         Check_Elaboration_Code_Allowed (gnat_node);
4095     }
4096
4097   switch (kind)
4098     {
4099       /********************************/
4100       /* Chapter 2: Lexical Elements  */
4101       /********************************/
4102
4103     case N_Identifier:
4104     case N_Expanded_Name:
4105     case N_Operator_Symbol:
4106     case N_Defining_Identifier:
4107       gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
4108       break;
4109
4110     case N_Integer_Literal:
4111       {
4112         tree gnu_type;
4113
4114         /* Get the type of the result, looking inside any padding and
4115            justified modular types.  Then get the value in that type.  */
4116         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
4117
4118         if (TREE_CODE (gnu_type) == RECORD_TYPE
4119             && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
4120           gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
4121
4122         gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
4123
4124         /* If the result overflows (meaning it doesn't fit in its base type),
4125            abort.  We would like to check that the value is within the range
4126            of the subtype, but that causes problems with subtypes whose usage
4127            will raise Constraint_Error and with biased representation, so
4128            we don't.  */
4129         gcc_assert (!TREE_OVERFLOW (gnu_result));
4130       }
4131       break;
4132
4133     case N_Character_Literal:
4134       /* If a Entity is present, it means that this was one of the
4135          literals in a user-defined character type.  In that case,
4136          just return the value in the CONST_DECL.  Otherwise, use the
4137          character code.  In that case, the base type should be an
4138          INTEGER_TYPE, but we won't bother checking for that.  */
4139       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4140       if (Present (Entity (gnat_node)))
4141         gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
4142       else
4143         gnu_result
4144           = build_int_cst_type
4145               (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
4146       break;
4147
4148     case N_Real_Literal:
4149       /* If this is of a fixed-point type, the value we want is the
4150          value of the corresponding integer.  */
4151       if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
4152         {
4153           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4154           gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
4155                                   gnu_result_type);
4156           gcc_assert (!TREE_OVERFLOW (gnu_result));
4157         }
4158
4159       /* We should never see a Vax_Float type literal, since the front end
4160          is supposed to transform these using appropriate conversions.  */
4161       else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
4162         gcc_unreachable ();
4163
4164       else
4165         {
4166           Ureal ur_realval = Realval (gnat_node);
4167
4168           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4169
4170           /* If the real value is zero, so is the result.  Otherwise,
4171              convert it to a machine number if it isn't already.  That
4172              forces BASE to 0 or 2 and simplifies the rest of our logic.  */
4173           if (UR_Is_Zero (ur_realval))
4174             gnu_result = convert (gnu_result_type, integer_zero_node);
4175           else
4176             {
4177               if (!Is_Machine_Number (gnat_node))
4178                 ur_realval
4179                   = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
4180                              ur_realval, Round_Even, gnat_node);
4181
4182               gnu_result
4183                 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
4184
4185               /* If we have a base of zero, divide by the denominator.
4186                  Otherwise, the base must be 2 and we scale the value, which
4187                  we know can fit in the mantissa of the type (hence the use
4188                  of that type above).  */
4189               if (No (Rbase (ur_realval)))
4190                 gnu_result
4191                   = build_binary_op (RDIV_EXPR,
4192                                      get_base_type (gnu_result_type),
4193                                      gnu_result,
4194                                      UI_To_gnu (Denominator (ur_realval),
4195                                                 gnu_result_type));
4196               else
4197                 {
4198                   REAL_VALUE_TYPE tmp;
4199
4200                   gcc_assert (Rbase (ur_realval) == 2);
4201                   real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
4202                               - UI_To_Int (Denominator (ur_realval)));
4203                   gnu_result = build_real (gnu_result_type, tmp);
4204                 }
4205             }
4206
4207           /* Now see if we need to negate the result.  Do it this way to
4208              properly handle -0.  */
4209           if (UR_Is_Negative (Realval (gnat_node)))
4210             gnu_result
4211               = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
4212                                 gnu_result);
4213         }
4214
4215       break;
4216
4217     case N_String_Literal:
4218       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4219       if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
4220         {
4221           String_Id gnat_string = Strval (gnat_node);
4222           int length = String_Length (gnat_string);
4223           int i;
4224           char *string;
4225           if (length >= ALLOCA_THRESHOLD)
4226             string = XNEWVEC (char, length + 1);
4227           else
4228             string = (char *) alloca (length + 1);
4229
4230           /* Build the string with the characters in the literal.  Note
4231              that Ada strings are 1-origin.  */
4232           for (i = 0; i < length; i++)
4233             string[i] = Get_String_Char (gnat_string, i + 1);
4234
4235           /* Put a null at the end of the string in case it's in a context
4236              where GCC will want to treat it as a C string.  */
4237           string[i] = 0;
4238
4239           gnu_result = build_string (length, string);
4240
4241           /* Strings in GCC don't normally have types, but we want
4242              this to not be converted to the array type.  */
4243           TREE_TYPE (gnu_result) = gnu_result_type;
4244
4245           if (length >= ALLOCA_THRESHOLD)
4246             free (string);
4247         }
4248       else
4249         {
4250           /* Build a list consisting of each character, then make
4251              the aggregate.  */
4252           String_Id gnat_string = Strval (gnat_node);
4253           int length = String_Length (gnat_string);
4254           int i;
4255           tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
4256           VEC(constructor_elt,gc) *gnu_vec
4257             = VEC_alloc (constructor_elt, gc, length);
4258
4259           for (i = 0; i < length; i++)
4260             {
4261               tree t = build_int_cst (TREE_TYPE (gnu_result_type),
4262                                       Get_String_Char (gnat_string, i + 1));
4263
4264               CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
4265               gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node);
4266             }
4267
4268           gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
4269         }
4270       break;
4271
4272     case N_Pragma:
4273       gnu_result = Pragma_to_gnu (gnat_node);
4274       break;
4275
4276     /**************************************/
4277     /* Chapter 3: Declarations and Types  */
4278     /**************************************/
4279
4280     case N_Subtype_Declaration:
4281     case N_Full_Type_Declaration:
4282     case N_Incomplete_Type_Declaration:
4283     case N_Private_Type_Declaration:
4284     case N_Private_Extension_Declaration:
4285     case N_Task_Type_Declaration:
4286       process_type (Defining_Entity (gnat_node));
4287       gnu_result = alloc_stmt_list ();
4288       break;
4289
4290     case N_Object_Declaration:
4291     case N_Exception_Declaration:
4292       gnat_temp = Defining_Entity (gnat_node);
4293       gnu_result = alloc_stmt_list ();
4294
4295       /* If we are just annotating types and this object has an unconstrained
4296          or task type, don't elaborate it.   */
4297       if (type_annotate_only
4298           && (((Is_Array_Type (Etype (gnat_temp))
4299                 || Is_Record_Type (Etype (gnat_temp)))
4300                && !Is_Constrained (Etype (gnat_temp)))
4301             || Is_Concurrent_Type (Etype (gnat_temp))))
4302         break;
4303
4304       if (Present (Expression (gnat_node))
4305           && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
4306           && (!type_annotate_only
4307               || Compile_Time_Known_Value (Expression (gnat_node))))
4308         {
4309           gnu_expr = gnat_to_gnu (Expression (gnat_node));
4310           if (Do_Range_Check (Expression (gnat_node)))
4311             gnu_expr
4312               = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
4313
4314           /* If this object has its elaboration delayed, we must force
4315              evaluation of GNU_EXPR right now and save it for when the object
4316              is frozen.  */
4317           if (Present (Freeze_Node (gnat_temp)))
4318             {
4319               if (TREE_CONSTANT (gnu_expr))
4320                 ;
4321               else if (global_bindings_p ())
4322                 gnu_expr
4323                   = create_var_decl (create_concat_name (gnat_temp, "init"),
4324                                      NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
4325                                      false, false, false, false,
4326                                      NULL, gnat_temp);
4327               else
4328                 gnu_expr = gnat_save_expr (gnu_expr);
4329
4330               save_gnu_tree (gnat_node, gnu_expr, true);
4331             }
4332         }
4333       else
4334         gnu_expr = NULL_TREE;
4335
4336       if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
4337         gnu_expr = NULL_TREE;
4338
4339       /* If this is a deferred constant with an address clause, we ignore the
4340          full view since the clause is on the partial view and we cannot have
4341          2 different GCC trees for the object.  The only bits of the full view
4342          we will use is the initializer, but it will be directly fetched.  */
4343       if (Ekind(gnat_temp) == E_Constant
4344           && Present (Address_Clause (gnat_temp))
4345           && Present (Full_View (gnat_temp)))
4346         save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
4347
4348       if (No (Freeze_Node (gnat_temp)))
4349         gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
4350       break;
4351
4352     case N_Object_Renaming_Declaration:
4353       gnat_temp = Defining_Entity (gnat_node);
4354
4355       /* Don't do anything if this renaming is handled by the front end or if
4356          we are just annotating types and this object has a composite or task
4357          type, don't elaborate it.  We return the result in case it has any
4358          SAVE_EXPRs in it that need to be evaluated here.  */
4359       if (!Is_Renaming_Of_Object (gnat_temp)
4360           && ! (type_annotate_only
4361                 && (Is_Array_Type (Etype (gnat_temp))
4362                     || Is_Record_Type (Etype (gnat_temp))
4363                     || Is_Concurrent_Type (Etype (gnat_temp)))))
4364         gnu_result
4365           = gnat_to_gnu_entity (gnat_temp,
4366                                 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
4367       else
4368         gnu_result = alloc_stmt_list ();
4369       break;
4370
4371     case N_Implicit_Label_Declaration:
4372       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
4373       gnu_result = alloc_stmt_list ();
4374       break;
4375
4376     case N_Exception_Renaming_Declaration:
4377     case N_Number_Declaration:
4378     case N_Package_Renaming_Declaration:
4379     case N_Subprogram_Renaming_Declaration:
4380       /* These are fully handled in the front end.  */
4381       gnu_result = alloc_stmt_list ();
4382       break;
4383
4384     /*************************************/
4385     /* Chapter 4: Names and Expressions  */
4386     /*************************************/
4387
4388     case N_Explicit_Dereference:
4389       gnu_result = gnat_to_gnu (Prefix (gnat_node));
4390       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4391       gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
4392       break;
4393
4394     case N_Indexed_Component:
4395       {
4396         tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
4397         tree gnu_type;
4398         int ndim;
4399         int i;
4400         Node_Id *gnat_expr_array;
4401
4402         gnu_array_object = maybe_implicit_deref (gnu_array_object);
4403
4404         /* Convert vector inputs to their representative array type, to fit
4405            what the code below expects.  */
4406         gnu_array_object = maybe_vector_array (gnu_array_object);
4407
4408         gnu_array_object = maybe_unconstrained_array (gnu_array_object);
4409
4410         /* If we got a padded type, remove it too.  */
4411         if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
4412           gnu_array_object
4413             = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
4414                        gnu_array_object);
4415
4416         gnu_result = gnu_array_object;
4417
4418         /* First compute the number of dimensions of the array, then
4419            fill the expression array, the order depending on whether
4420            this is a Convention_Fortran array or not.  */
4421         for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
4422              TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
4423              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
4424              ndim++, gnu_type = TREE_TYPE (gnu_type))
4425           ;
4426
4427         gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
4428
4429         if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
4430           for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
4431                i >= 0;
4432                i--, gnat_temp = Next (gnat_temp))
4433             gnat_expr_array[i] = gnat_temp;
4434         else
4435           for (i = 0, gnat_temp = First (Expressions (gnat_node));
4436                i < ndim;
4437                i++, gnat_temp = Next (gnat_temp))
4438             gnat_expr_array[i] = gnat_temp;
4439
4440         for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
4441              i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
4442           {
4443             gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
4444             gnat_temp = gnat_expr_array[i];
4445             gnu_expr = gnat_to_gnu (gnat_temp);
4446
4447             if (Do_Range_Check (gnat_temp))
4448               gnu_expr
4449                 = emit_index_check
4450                   (gnu_array_object, gnu_expr,
4451                    TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
4452                    TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
4453                    gnat_temp);
4454
4455             gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
4456                                           gnu_result, gnu_expr);
4457           }
4458       }
4459
4460       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4461       break;
4462
4463     case N_Slice:
4464       {
4465         Node_Id gnat_range_node = Discrete_Range (gnat_node);
4466         tree gnu_type;
4467
4468         gnu_result = gnat_to_gnu (Prefix (gnat_node));
4469         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4470
4471         /* Do any implicit dereferences of the prefix and do any needed
4472            range check.  */
4473         gnu_result = maybe_implicit_deref (gnu_result);
4474         gnu_result = maybe_unconstrained_array (gnu_result);
4475         gnu_type = TREE_TYPE (gnu_result);
4476         if (Do_Range_Check (gnat_range_node))
4477           {
4478             /* Get the bounds of the slice.  */
4479             tree gnu_index_type
4480               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
4481             tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
4482             tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
4483             /* Get the permitted bounds.  */
4484             tree gnu_base_index_type
4485               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
4486             tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
4487               (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
4488             tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
4489               (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
4490             tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
4491
4492            gnu_min_expr = gnat_protect_expr (gnu_min_expr);
4493            gnu_max_expr = gnat_protect_expr (gnu_max_expr);
4494
4495             /* Derive a good type to convert everything to.  */
4496             gnu_expr_type = get_base_type (gnu_index_type);
4497
4498             /* Test whether the minimum slice value is too small.  */
4499             gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
4500                                           convert (gnu_expr_type,
4501                                                    gnu_min_expr),
4502                                           convert (gnu_expr_type,
4503                                                    gnu_base_min_expr));
4504
4505             /* Test whether the maximum slice value is too large.  */
4506             gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
4507                                           convert (gnu_expr_type,
4508                                                    gnu_max_expr),
4509                                           convert (gnu_expr_type,
4510                                                    gnu_base_max_expr));
4511
4512             /* Build a slice index check that returns the low bound,
4513                assuming the slice is not empty.  */
4514             gnu_expr = emit_check
4515               (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
4516                                 gnu_expr_l, gnu_expr_h),
4517                gnu_min_expr, CE_Index_Check_Failed, gnat_node);
4518
4519            /* Build a conditional expression that does the index checks and
4520               returns the low bound if the slice is not empty (max >= min),
4521               and returns the naked low bound otherwise (max < min), unless
4522               it is non-constant and the high bound is; this prevents VRP
4523               from inferring bogus ranges on the unlikely path.  */
4524             gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
4525                                     build_binary_op (GE_EXPR, gnu_expr_type,
4526                                                      convert (gnu_expr_type,
4527                                                               gnu_max_expr),
4528                                                      convert (gnu_expr_type,
4529                                                               gnu_min_expr)),
4530                                     gnu_expr,
4531                                     TREE_CODE (gnu_min_expr) != INTEGER_CST
4532                                     && TREE_CODE (gnu_max_expr) == INTEGER_CST
4533                                     ? gnu_max_expr : gnu_min_expr);
4534           }
4535         else
4536           /* Simply return the naked low bound.  */
4537           gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
4538
4539         /* If this is a slice with non-constant size of an array with constant
4540            size, set the maximum size for the allocation of temporaries.  */
4541         if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
4542             && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
4543           TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
4544
4545         gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
4546                                       gnu_result, gnu_expr);
4547       }
4548       break;
4549
4550     case N_Selected_Component:
4551       {
4552         tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
4553         Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
4554         Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
4555         tree gnu_field;
4556
4557         while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
4558                || IN (Ekind (gnat_pref_type), Access_Kind))
4559           {
4560             if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
4561               gnat_pref_type = Underlying_Type (gnat_pref_type);
4562             else if (IN (Ekind (gnat_pref_type), Access_Kind))
4563               gnat_pref_type = Designated_Type (gnat_pref_type);
4564           }
4565
4566         gnu_prefix = maybe_implicit_deref (gnu_prefix);
4567
4568         /* For discriminant references in tagged types always substitute the
4569            corresponding discriminant as the actual selected component.  */
4570         if (Is_Tagged_Type (gnat_pref_type))
4571           while (Present (Corresponding_Discriminant (gnat_field)))
4572             gnat_field = Corresponding_Discriminant (gnat_field);
4573
4574         /* For discriminant references of untagged types always substitute the
4575            corresponding stored discriminant.  */
4576         else if (Present (Corresponding_Discriminant (gnat_field)))
4577           gnat_field = Original_Record_Component (gnat_field);
4578
4579         /* Handle extracting the real or imaginary part of a complex.
4580            The real part is the first field and the imaginary the last.  */
4581         if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
4582           gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
4583                                        ? REALPART_EXPR : IMAGPART_EXPR,
4584                                        NULL_TREE, gnu_prefix);
4585         else
4586           {
4587             gnu_field = gnat_to_gnu_field_decl (gnat_field);
4588
4589             /* If there are discriminants, the prefix might be evaluated more
4590                than once, which is a problem if it has side-effects.  */
4591             if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
4592                                    ? Designated_Type (Etype
4593                                                       (Prefix (gnat_node)))
4594                                    : Etype (Prefix (gnat_node))))
4595               gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL);
4596
4597             gnu_result
4598               = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
4599                                      (Nkind (Parent (gnat_node))
4600                                       == N_Attribute_Reference)
4601                                      && lvalue_required_for_attribute_p
4602                                         (Parent (gnat_node)));
4603           }
4604
4605         gcc_assert (gnu_result);
4606         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4607       }
4608       break;
4609
4610     case N_Attribute_Reference:
4611       {
4612         /* The attribute designator.  */
4613         const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
4614
4615         /* The Elab_Spec and Elab_Body attributes are special in that Prefix
4616            is a unit, not an object with a GCC equivalent.  */
4617         if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
4618           return
4619             create_subprog_decl (create_concat_name
4620                                  (Entity (Prefix (gnat_node)),
4621                                   attr == Attr_Elab_Body ? "elabb" : "elabs"),
4622                                  NULL_TREE, void_ftype, NULL_TREE, false,
4623                                  true, true, true, NULL, gnat_node);
4624
4625         gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
4626       }
4627       break;
4628
4629     case N_Reference:
4630       /* Like 'Access as far as we are concerned.  */
4631       gnu_result = gnat_to_gnu (Prefix (gnat_node));
4632       gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
4633       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4634       break;
4635
4636     case N_Aggregate:
4637     case N_Extension_Aggregate:
4638       {
4639         tree gnu_aggr_type;
4640
4641         /* ??? It is wrong to evaluate the type now, but there doesn't
4642            seem to be any other practical way of doing it.  */
4643
4644         gcc_assert (!Expansion_Delayed (gnat_node));
4645
4646         gnu_aggr_type = gnu_result_type
4647           = get_unpadded_type (Etype (gnat_node));
4648
4649         if (TREE_CODE (gnu_result_type) == RECORD_TYPE
4650             && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
4651           gnu_aggr_type
4652             = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
4653         else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
4654           gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
4655
4656         if (Null_Record_Present (gnat_node))
4657           gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
4658
4659         else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
4660                  || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
4661           gnu_result
4662             = assoc_to_constructor (Etype (gnat_node),
4663                                     First (Component_Associations (gnat_node)),
4664                                     gnu_aggr_type);
4665         else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
4666           gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
4667                                            gnu_aggr_type,
4668                                            Component_Type (Etype (gnat_node)));
4669         else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
4670           gnu_result
4671             = build_binary_op
4672               (COMPLEX_EXPR, gnu_aggr_type,
4673                gnat_to_gnu (Expression (First
4674                                         (Component_Associations (gnat_node)))),
4675                gnat_to_gnu (Expression
4676                             (Next
4677                              (First (Component_Associations (gnat_node))))));
4678         else
4679           gcc_unreachable ();
4680
4681         gnu_result = convert (gnu_result_type, gnu_result);
4682       }
4683       break;
4684
4685     case N_Null:
4686       if (TARGET_VTABLE_USES_DESCRIPTORS
4687           && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
4688           && Is_Dispatch_Table_Entity (Etype (gnat_node)))
4689         gnu_result = null_fdesc_node;
4690       else
4691         gnu_result = null_pointer_node;
4692       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4693       break;
4694
4695     case N_Type_Conversion:
4696     case N_Qualified_Expression:
4697       /* Get the operand expression.  */
4698       gnu_result = gnat_to_gnu (Expression (gnat_node));
4699       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4700
4701       gnu_result
4702         = convert_with_check (Etype (gnat_node), gnu_result,
4703                               Do_Overflow_Check (gnat_node),
4704                               Do_Range_Check (Expression (gnat_node)),
4705                               kind == N_Type_Conversion
4706                               && Float_Truncate (gnat_node), gnat_node);
4707       break;
4708
4709     case N_Unchecked_Type_Conversion:
4710       gnu_result = gnat_to_gnu (Expression (gnat_node));
4711
4712       /* Skip further processing if the conversion is deemed a no-op.  */
4713       if (unchecked_conversion_nop (gnat_node))
4714         {
4715           gnu_result_type = TREE_TYPE (gnu_result);
4716           break;
4717         }
4718
4719       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4720
4721       /* If the result is a pointer type, see if we are improperly
4722          converting to a stricter alignment.  */
4723       if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
4724           && IN (Ekind (Etype (gnat_node)), Access_Kind))
4725         {
4726           unsigned int align = known_alignment (gnu_result);
4727           tree gnu_obj_type = TREE_TYPE (gnu_result_type);
4728           unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
4729
4730           if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
4731             post_error_ne_tree_2
4732               ("?source alignment (^) '< alignment of & (^)",
4733                gnat_node, Designated_Type (Etype (gnat_node)),
4734                size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
4735         }
4736
4737       /* If we are converting a descriptor to a function pointer, first
4738          build the pointer.  */
4739       if (TARGET_VTABLE_USES_DESCRIPTORS
4740           && TREE_TYPE (gnu_result) == fdesc_type_node
4741           && POINTER_TYPE_P (gnu_result_type))
4742         gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
4743
4744       gnu_result = unchecked_convert (gnu_result_type, gnu_result,
4745                                       No_Truncation (gnat_node));
4746       break;
4747
4748     case N_In:
4749     case N_Not_In:
4750       {
4751         tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
4752         Node_Id gnat_range = Right_Opnd (gnat_node);
4753         tree gnu_low, gnu_high;
4754
4755         /* GNAT_RANGE is either an N_Range node or an identifier denoting a
4756            subtype.  */
4757         if (Nkind (gnat_range) == N_Range)
4758           {
4759             gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
4760             gnu_high = gnat_to_gnu (High_Bound (gnat_range));
4761           }
4762         else if (Nkind (gnat_range) == N_Identifier
4763                  || Nkind (gnat_range) == N_Expanded_Name)
4764           {
4765             tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
4766
4767             gnu_low = TYPE_MIN_VALUE (gnu_range_type);
4768             gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4769           }
4770         else
4771           gcc_unreachable ();
4772
4773         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4774
4775         /* If LOW and HIGH are identical, perform an equality test.  Otherwise,
4776            ensure that GNU_OBJ is evaluated only once and perform a full range
4777            test.  */
4778         if (operand_equal_p (gnu_low, gnu_high, 0))
4779           gnu_result
4780             = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
4781         else
4782           {
4783             tree t1, t2;
4784             gnu_obj = gnat_protect_expr (gnu_obj);
4785             t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
4786             if (EXPR_P (t1))
4787               set_expr_location_from_node (t1, gnat_node);
4788             t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
4789             if (EXPR_P (t2))
4790               set_expr_location_from_node (t2, gnat_node);
4791             gnu_result
4792               = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
4793           }
4794
4795         if (kind == N_Not_In)
4796           gnu_result
4797             = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
4798       }
4799       break;
4800
4801     case N_Op_Divide:
4802       gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4803       gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4804       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4805       gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
4806                                     ? RDIV_EXPR
4807                                     : (Rounded_Result (gnat_node)
4808                                        ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
4809                                     gnu_result_type, gnu_lhs, gnu_rhs);
4810       break;
4811
4812     case N_Op_Or:    case N_Op_And:      case N_Op_Xor:
4813       /* These can either be operations on booleans or on modular types.
4814          Fall through for boolean types since that's the way GNU_CODES is
4815          set up.  */
4816       if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
4817               Modular_Integer_Kind))
4818         {
4819           enum tree_code code
4820             = (kind == N_Op_Or ? BIT_IOR_EXPR
4821                : kind == N_Op_And ? BIT_AND_EXPR
4822                : BIT_XOR_EXPR);
4823
4824           gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4825           gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4826           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4827           gnu_result = build_binary_op (code, gnu_result_type,
4828                                         gnu_lhs, gnu_rhs);
4829           break;
4830         }
4831
4832       /* ... fall through ... */
4833
4834     case N_Op_Eq:    case N_Op_Ne:       case N_Op_Lt:
4835     case N_Op_Le:    case N_Op_Gt:       case N_Op_Ge:
4836     case N_Op_Add:   case N_Op_Subtract: case N_Op_Multiply:
4837     case N_Op_Mod:   case N_Op_Rem:
4838     case N_Op_Rotate_Left:
4839     case N_Op_Rotate_Right:
4840     case N_Op_Shift_Left:
4841     case N_Op_Shift_Right:
4842     case N_Op_Shift_Right_Arithmetic:
4843     case N_And_Then: case N_Or_Else:
4844       {
4845         enum tree_code code = gnu_codes[kind];
4846         bool ignore_lhs_overflow = false;
4847         location_t saved_location = input_location;
4848         tree gnu_type;
4849
4850         gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4851         gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4852         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
4853
4854         /* Pending generic support for efficient vector logical operations in
4855            GCC, convert vectors to their representative array type view and
4856            fallthrough.  */
4857         gnu_lhs = maybe_vector_array (gnu_lhs);
4858         gnu_rhs = maybe_vector_array (gnu_rhs);
4859
4860         /* If this is a comparison operator, convert any references to
4861            an unconstrained array value into a reference to the
4862            actual array.  */
4863         if (TREE_CODE_CLASS (code) == tcc_comparison)
4864           {
4865             gnu_lhs = maybe_unconstrained_array (gnu_lhs);
4866             gnu_rhs = maybe_unconstrained_array (gnu_rhs);
4867           }
4868
4869         /* If the result type is a private type, its full view may be a
4870            numeric subtype. The representation we need is that of its base
4871            type, given that it is the result of an arithmetic operation.  */
4872         else if (Is_Private_Type (Etype (gnat_node)))
4873           gnu_type = gnu_result_type
4874             = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
4875
4876         /* If this is a shift whose count is not guaranteed to be correct,
4877            we need to adjust the shift count.  */
4878         if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
4879           {
4880             tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
4881             tree gnu_max_shift
4882               = convert (gnu_count_type, TYPE_SIZE (gnu_type));
4883
4884             if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
4885               gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
4886                                          gnu_rhs, gnu_max_shift);
4887             else if (kind == N_Op_Shift_Right_Arithmetic)
4888               gnu_rhs
4889                 = build_binary_op
4890                   (MIN_EXPR, gnu_count_type,
4891                    build_binary_op (MINUS_EXPR,
4892                                     gnu_count_type,
4893                                     gnu_max_shift,
4894                                     convert (gnu_count_type,
4895                                              integer_one_node)),
4896                    gnu_rhs);
4897           }
4898
4899         /* For right shifts, the type says what kind of shift to do,
4900            so we may need to choose a different type.  In this case,
4901            we have to ignore integer overflow lest it propagates all
4902            the way down and causes a CE to be explicitly raised.  */
4903         if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
4904           {
4905             gnu_type = gnat_unsigned_type (gnu_type);
4906             ignore_lhs_overflow = true;
4907           }
4908         else if (kind == N_Op_Shift_Right_Arithmetic
4909                  && TYPE_UNSIGNED (gnu_type))
4910           {
4911             gnu_type = gnat_signed_type (gnu_type);
4912             ignore_lhs_overflow = true;
4913           }
4914
4915         if (gnu_type != gnu_result_type)
4916           {
4917             tree gnu_old_lhs = gnu_lhs;
4918             gnu_lhs = convert (gnu_type, gnu_lhs);
4919             if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
4920               TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
4921             gnu_rhs = convert (gnu_type, gnu_rhs);
4922           }
4923
4924         /* Instead of expanding overflow checks for addition, subtraction
4925            and multiplication itself, the front end will leave this to
4926            the back end when Backend_Overflow_Checks_On_Target is set.
4927            As the GCC back end itself does not know yet how to properly
4928            do overflow checking, do it here.  The goal is to push
4929            the expansions further into the back end over time.  */
4930         if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
4931             && (kind == N_Op_Add
4932                 || kind == N_Op_Subtract
4933                 || kind == N_Op_Multiply)
4934             && !TYPE_UNSIGNED (gnu_type)
4935             && !FLOAT_TYPE_P (gnu_type))
4936           gnu_result = build_binary_op_trapv (code, gnu_type,
4937                                               gnu_lhs, gnu_rhs, gnat_node);
4938         else
4939           {
4940             /* Some operations, e.g. comparisons of arrays, generate complex
4941                trees that need to be annotated while they are being built.  */
4942             input_location = saved_location;
4943             gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
4944           }
4945
4946         /* If this is a logical shift with the shift count not verified,
4947            we must return zero if it is too large.  We cannot compensate
4948            above in this case.  */
4949         if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
4950             && !Shift_Count_OK (gnat_node))
4951           gnu_result
4952             = build_cond_expr
4953               (gnu_type,
4954                build_binary_op (GE_EXPR, boolean_type_node,
4955                                 gnu_rhs,
4956                                 convert (TREE_TYPE (gnu_rhs),
4957                                          TYPE_SIZE (gnu_type))),
4958                convert (gnu_type, integer_zero_node),
4959                gnu_result);
4960       }
4961       break;
4962
4963     case N_Conditional_Expression:
4964       {
4965         tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
4966         tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
4967         tree gnu_false
4968           = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
4969
4970         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4971         gnu_result
4972           = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
4973       }
4974       break;
4975
4976     case N_Op_Plus:
4977       gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
4978       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4979       break;
4980
4981     case N_Op_Not:
4982       /* This case can apply to a boolean or a modular type.
4983          Fall through for a boolean operand since GNU_CODES is set
4984          up to handle this.  */
4985       if (Is_Modular_Integer_Type (Etype (gnat_node))
4986           || (Ekind (Etype (gnat_node)) == E_Private_Type
4987               && Is_Modular_Integer_Type (Full_View (Etype (gnat_node)))))
4988         {
4989           gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
4990           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4991           gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
4992                                        gnu_expr);
4993           break;
4994         }
4995
4996       /* ... fall through ... */
4997
4998     case N_Op_Minus:  case N_Op_Abs:
4999       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
5000
5001       if (Ekind (Etype (gnat_node)) != E_Private_Type)
5002         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5003       else
5004         gnu_result_type = get_unpadded_type (Base_Type
5005                                              (Full_View (Etype (gnat_node))));
5006
5007       if (Do_Overflow_Check (gnat_node)
5008           && !TYPE_UNSIGNED (gnu_result_type)
5009           && !FLOAT_TYPE_P (gnu_result_type))
5010         gnu_result
5011           = build_unary_op_trapv (gnu_codes[kind],
5012                                   gnu_result_type, gnu_expr, gnat_node);
5013       else
5014         gnu_result = build_unary_op (gnu_codes[kind],
5015                                      gnu_result_type, gnu_expr);
5016       break;
5017
5018     case N_Allocator:
5019       {
5020         tree gnu_init = 0;
5021         tree gnu_type;
5022         bool ignore_init_type = false;
5023
5024         gnat_temp = Expression (gnat_node);
5025
5026         /* The Expression operand can either be an N_Identifier or
5027            Expanded_Name, which must represent a type, or a
5028            N_Qualified_Expression, which contains both the object type and an
5029            initial value for the object.  */
5030         if (Nkind (gnat_temp) == N_Identifier
5031             || Nkind (gnat_temp) == N_Expanded_Name)
5032           gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
5033         else if (Nkind (gnat_temp) == N_Qualified_Expression)
5034           {
5035             Entity_Id gnat_desig_type
5036               = Designated_Type (Underlying_Type (Etype (gnat_node)));
5037
5038             ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
5039             gnu_init = gnat_to_gnu (Expression (gnat_temp));
5040
5041             gnu_init = maybe_unconstrained_array (gnu_init);
5042             if (Do_Range_Check (Expression (gnat_temp)))
5043               gnu_init
5044                 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
5045
5046             if (Is_Elementary_Type (gnat_desig_type)
5047                 || Is_Constrained (gnat_desig_type))
5048               {
5049                 gnu_type = gnat_to_gnu_type (gnat_desig_type);
5050                 gnu_init = convert (gnu_type, gnu_init);
5051               }
5052             else
5053               {
5054                 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
5055                 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
5056                   gnu_type = TREE_TYPE (gnu_init);
5057
5058                 gnu_init = convert (gnu_type, gnu_init);
5059               }
5060           }
5061         else
5062           gcc_unreachable ();
5063
5064         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5065         return build_allocator (gnu_type, gnu_init, gnu_result_type,
5066                                 Procedure_To_Call (gnat_node),
5067                                 Storage_Pool (gnat_node), gnat_node,
5068                                 ignore_init_type);
5069       }
5070       break;
5071
5072     /**************************/
5073     /* Chapter 5: Statements  */
5074     /**************************/
5075
5076     case N_Label:
5077       gnu_result = build1 (LABEL_EXPR, void_type_node,
5078                            gnat_to_gnu (Identifier (gnat_node)));
5079       break;
5080
5081     case N_Null_Statement:
5082       /* When not optimizing, turn null statements from source into gotos to
5083          the next statement that the middle-end knows how to preserve.  */
5084       if (!optimize && Comes_From_Source (gnat_node))
5085         {
5086           tree stmt, label = create_label_decl (NULL_TREE);
5087           start_stmt_group ();
5088           stmt = build1 (GOTO_EXPR, void_type_node, label);
5089           set_expr_location_from_node (stmt, gnat_node);
5090           add_stmt (stmt);
5091           stmt = build1 (LABEL_EXPR, void_type_node, label);
5092           set_expr_location_from_node (stmt, gnat_node);
5093           add_stmt (stmt);
5094           gnu_result = end_stmt_group ();
5095         }
5096       else
5097         gnu_result = alloc_stmt_list ();
5098       break;
5099
5100     case N_Assignment_Statement:
5101       /* Get the LHS and RHS of the statement and convert any reference to an
5102          unconstrained array into a reference to the underlying array.  */
5103       gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
5104
5105       /* If the type has a size that overflows, convert this into raise of
5106          Storage_Error: execution shouldn't have gotten here anyway.  */
5107       if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
5108            && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
5109         gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
5110                                        N_Raise_Storage_Error);
5111       else if (Nkind (Expression (gnat_node)) == N_Function_Call)
5112         gnu_result
5113           = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs);
5114       else
5115         {
5116           gnu_rhs
5117             = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
5118
5119           /* If range check is needed, emit code to generate it.  */
5120           if (Do_Range_Check (Expression (gnat_node)))
5121             gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
5122                                         gnat_node);
5123
5124           gnu_result
5125             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
5126
5127           /* If the type being assigned is an array type and the two sides are
5128              not completely disjoint, play safe and use memmove.  But don't do
5129              it for a bit-packed array as it might not be byte-aligned.  */
5130           if (TREE_CODE (gnu_result) == MODIFY_EXPR
5131               && Is_Array_Type (Etype (Name (gnat_node)))
5132               && !Is_Bit_Packed_Array (Etype (Name (gnat_node)))
5133               && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
5134             {
5135               tree to, from, size, to_ptr, from_ptr, t;
5136
5137               to = TREE_OPERAND (gnu_result, 0);
5138               from = TREE_OPERAND (gnu_result, 1);
5139
5140               size = TYPE_SIZE_UNIT (TREE_TYPE (from));
5141               size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from);
5142
5143               to_ptr = build_fold_addr_expr (to);
5144               from_ptr = build_fold_addr_expr (from);
5145
5146               t = implicit_built_in_decls[BUILT_IN_MEMMOVE];
5147               gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
5148            }
5149         }
5150       break;
5151
5152     case N_If_Statement:
5153       {
5154         tree *gnu_else_ptr; /* Point to put next "else if" or "else".  */
5155
5156         /* Make the outer COND_EXPR.  Avoid non-determinism.  */
5157         gnu_result = build3 (COND_EXPR, void_type_node,
5158                              gnat_to_gnu (Condition (gnat_node)),
5159                              NULL_TREE, NULL_TREE);
5160         COND_EXPR_THEN (gnu_result)
5161           = build_stmt_group (Then_Statements (gnat_node), false);
5162         TREE_SIDE_EFFECTS (gnu_result) = 1;
5163         gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
5164
5165         /* Now make a COND_EXPR for each of the "else if" parts.  Put each
5166            into the previous "else" part and point to where to put any
5167            outer "else".  Also avoid non-determinism.  */
5168         if (Present (Elsif_Parts (gnat_node)))
5169           for (gnat_temp = First (Elsif_Parts (gnat_node));
5170                Present (gnat_temp); gnat_temp = Next (gnat_temp))
5171             {
5172               gnu_expr = build3 (COND_EXPR, void_type_node,
5173                                  gnat_to_gnu (Condition (gnat_temp)),
5174                                  NULL_TREE, NULL_TREE);
5175               COND_EXPR_THEN (gnu_expr)
5176                 = build_stmt_group (Then_Statements (gnat_temp), false);
5177               TREE_SIDE_EFFECTS (gnu_expr) = 1;
5178               set_expr_location_from_node (gnu_expr, gnat_temp);
5179               *gnu_else_ptr = gnu_expr;
5180               gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
5181             }
5182
5183         *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
5184       }
5185       break;
5186
5187     case N_Case_Statement:
5188       gnu_result = Case_Statement_to_gnu (gnat_node);
5189       break;
5190
5191     case N_Loop_Statement:
5192       gnu_result = Loop_Statement_to_gnu (gnat_node);
5193       break;
5194
5195     case N_Block_Statement:
5196       start_stmt_group ();
5197       gnat_pushlevel ();
5198       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
5199       add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
5200       gnat_poplevel ();
5201       gnu_result = end_stmt_group ();
5202
5203       if (Present (Identifier (gnat_node)))
5204         mark_out_of_scope (Entity (Identifier (gnat_node)));
5205       break;
5206
5207     case N_Exit_Statement:
5208       gnu_result
5209         = build2 (EXIT_STMT, void_type_node,
5210                   (Present (Condition (gnat_node))
5211                    ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
5212                   (Present (Name (gnat_node))
5213                    ? get_gnu_tree (Entity (Name (gnat_node)))
5214                    : VEC_last (tree, gnu_loop_label_stack)));
5215       break;
5216
5217     case N_Return_Statement:
5218       {
5219         tree gnu_ret_obj, gnu_ret_val;
5220
5221         /* If the subprogram is a function, we must return the expression.  */
5222         if (Present (Expression (gnat_node)))
5223           {
5224             tree gnu_subprog_type = TREE_TYPE (current_function_decl);
5225
5226             /* If this function has copy-in/copy-out parameters, get the real
5227                object for the return.  See Subprogram_to_gnu.  */
5228             if (TYPE_CI_CO_LIST (gnu_subprog_type))
5229               gnu_ret_obj = VEC_last (tree, gnu_return_var_stack);
5230             else
5231               gnu_ret_obj = DECL_RESULT (current_function_decl);
5232
5233             /* Get the GCC tree for the expression to be returned.  */
5234             gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
5235
5236             /* Do not remove the padding from GNU_RET_VAL if the inner type is
5237                self-referential since we want to allocate the fixed size.  */
5238             if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
5239                 && TYPE_IS_PADDING_P
5240                    (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
5241                 && CONTAINS_PLACEHOLDER_P
5242                    (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
5243               gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
5244
5245             /* If the function returns by direct reference, return a pointer
5246                to the return value.  */
5247             if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
5248                 || By_Ref (gnat_node))
5249               gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
5250
5251             /* Otherwise, if it returns an unconstrained array, we have to
5252                allocate a new version of the result and return it.  */
5253             else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
5254               {
5255                 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
5256                 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
5257                                                gnu_ret_val,
5258                                                TREE_TYPE (gnu_ret_obj),
5259                                                Procedure_To_Call (gnat_node),
5260                                                Storage_Pool (gnat_node),
5261                                                gnat_node, false);
5262               }
5263
5264             /* If the function returns by invisible reference, dereference
5265                the pointer it is passed using the type of the return value
5266                and build the copy operation manually.  This ensures that we
5267                don't copy too much data, for example if the return type is
5268                unconstrained with a maximum size.  */
5269             if (TREE_ADDRESSABLE (gnu_subprog_type))
5270               {
5271                 tree gnu_ret_deref
5272                   = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
5273                                     gnu_ret_obj);
5274                 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
5275                                               gnu_ret_deref, gnu_ret_val);
5276                 add_stmt_with_node (gnu_result, gnat_node);
5277                 gnu_ret_val = NULL_TREE;
5278               }
5279           }
5280         else
5281           {
5282             gnu_ret_obj = NULL_TREE;
5283             gnu_ret_val = NULL_TREE;
5284           }
5285
5286         /* If we have a return label defined, convert this into a branch to
5287            that label.  The return proper will be handled elsewhere.  */
5288         if (VEC_last (tree, gnu_return_label_stack))
5289           {
5290             if (gnu_ret_obj)
5291               add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
5292                                          gnu_ret_val));
5293
5294             gnu_result = build1 (GOTO_EXPR, void_type_node,
5295                                  VEC_last (tree, gnu_return_label_stack));
5296
5297             /* When not optimizing, make sure the return is preserved.  */
5298             if (!optimize && Comes_From_Source (gnat_node))
5299               DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0;
5300           }
5301
5302         /* Otherwise, build a regular return.  */
5303         else
5304           gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
5305       }
5306       break;
5307
5308     case N_Goto_Statement:
5309       gnu_result = build1 (GOTO_EXPR, void_type_node,
5310                            gnat_to_gnu (Name (gnat_node)));
5311       break;
5312
5313     /***************************/
5314     /* Chapter 6: Subprograms  */
5315     /***************************/
5316
5317     case N_Subprogram_Declaration:
5318       /* Unless there is a freeze node, declare the subprogram.  We consider
5319          this a "definition" even though we're not generating code for
5320          the subprogram because we will be making the corresponding GCC
5321          node here.  */
5322
5323       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
5324         gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
5325                             NULL_TREE, 1);
5326       gnu_result = alloc_stmt_list ();
5327       break;
5328
5329     case N_Abstract_Subprogram_Declaration:
5330       /* This subprogram doesn't exist for code generation purposes, but we
5331          have to elaborate the types of any parameters and result, unless
5332          they are imported types (nothing to generate in this case).
5333
5334          The parameter list may contain types with freeze nodes, e.g. not null
5335          subtypes, so the subprogram itself may carry a freeze node, in which
5336          case its elaboration must be deferred.  */
5337
5338       /* Process the parameter types first.  */
5339       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
5340       for (gnat_temp
5341            = First_Formal_With_Extras
5342               (Defining_Entity (Specification (gnat_node)));
5343            Present (gnat_temp);
5344            gnat_temp = Next_Formal_With_Extras (gnat_temp))
5345         if (Is_Itype (Etype (gnat_temp))
5346             && !From_With_Type (Etype (gnat_temp)))
5347           gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
5348
5349       /* Then the result type, set to Standard_Void_Type for procedures.  */
5350       {
5351         Entity_Id gnat_temp_type
5352           = Etype (Defining_Entity (Specification (gnat_node)));
5353
5354         if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
5355           gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
5356       }
5357
5358       gnu_result = alloc_stmt_list ();
5359       break;
5360
5361     case N_Defining_Program_Unit_Name:
5362       /* For a child unit identifier go up a level to get the specification.
5363          We get this when we try to find the spec of a child unit package
5364          that is the compilation unit being compiled.  */
5365       gnu_result = gnat_to_gnu (Parent (gnat_node));
5366       break;
5367
5368     case N_Subprogram_Body:
5369       Subprogram_Body_to_gnu (gnat_node);
5370       gnu_result = alloc_stmt_list ();
5371       break;
5372
5373     case N_Function_Call:
5374     case N_Procedure_Call_Statement:
5375       gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
5376       break;
5377
5378     /************************/
5379     /* Chapter 7: Packages  */
5380     /************************/
5381
5382     case N_Package_Declaration:
5383       gnu_result = gnat_to_gnu (Specification (gnat_node));
5384       break;
5385
5386     case N_Package_Specification:
5387
5388       start_stmt_group ();
5389       process_decls (Visible_Declarations (gnat_node),
5390                      Private_Declarations (gnat_node), Empty, true, true);
5391       gnu_result = end_stmt_group ();
5392       break;
5393
5394     case N_Package_Body:
5395
5396       /* If this is the body of a generic package - do nothing.  */
5397       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
5398         {
5399           gnu_result = alloc_stmt_list ();
5400           break;
5401         }
5402
5403       start_stmt_group ();
5404       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
5405
5406       if (Present (Handled_Statement_Sequence (gnat_node)))
5407         add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
5408
5409       gnu_result = end_stmt_group ();
5410       break;
5411
5412     /********************************/
5413     /* Chapter 8: Visibility Rules  */
5414     /********************************/
5415
5416     case N_Use_Package_Clause:
5417     case N_Use_Type_Clause:
5418       /* Nothing to do here - but these may appear in list of declarations.  */
5419       gnu_result = alloc_stmt_list ();
5420       break;
5421
5422     /*********************/
5423     /* Chapter 9: Tasks  */
5424     /*********************/
5425
5426     case N_Protected_Type_Declaration:
5427       gnu_result = alloc_stmt_list ();
5428       break;
5429
5430     case N_Single_Task_Declaration:
5431       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
5432       gnu_result = alloc_stmt_list ();
5433       break;
5434
5435     /*********************************************************/
5436     /* Chapter 10: Program Structure and Compilation Issues  */
5437     /*********************************************************/
5438
5439     case N_Compilation_Unit:
5440       /* This is not called for the main unit on which gigi is invoked.  */
5441       Compilation_Unit_to_gnu (gnat_node);
5442       gnu_result = alloc_stmt_list ();
5443       break;
5444
5445     case N_Subprogram_Body_Stub:
5446     case N_Package_Body_Stub:
5447     case N_Protected_Body_Stub:
5448     case N_Task_Body_Stub:
5449       /* Simply process whatever unit is being inserted.  */
5450       gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
5451       break;
5452
5453     case N_Subunit:
5454       gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
5455       break;
5456
5457     /***************************/
5458     /* Chapter 11: Exceptions  */
5459     /***************************/
5460
5461     case N_Handled_Sequence_Of_Statements:
5462       /* If there is an At_End procedure attached to this node, and the EH
5463          mechanism is SJLJ, we must have at least a corresponding At_End
5464          handler, unless the No_Exception_Handlers restriction is set.  */
5465       gcc_assert (type_annotate_only
5466                   || Exception_Mechanism != Setjmp_Longjmp
5467                   || No (At_End_Proc (gnat_node))
5468                   || Present (Exception_Handlers (gnat_node))
5469                   || No_Exception_Handlers_Set ());
5470
5471       gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
5472       break;
5473
5474     case N_Exception_Handler:
5475       if (Exception_Mechanism == Setjmp_Longjmp)
5476         gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
5477       else if (Exception_Mechanism == Back_End_Exceptions)
5478         gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
5479       else
5480         gcc_unreachable ();
5481       break;
5482
5483     case N_Raise_Statement:
5484       /* Only for reraise in back-end exceptions mode.  */
5485       gcc_assert (No (Name (gnat_node))
5486                   && Exception_Mechanism == Back_End_Exceptions);
5487
5488       start_stmt_group ();
5489       gnat_pushlevel ();
5490
5491       /* Clear the current exception pointer so that the occurrence won't be
5492          deallocated.  */
5493       gnu_expr = create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE,
5494                                   ptr_type_node, gnu_incoming_exc_ptr,
5495                                   false, false, false, false, NULL, gnat_node);
5496
5497       add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr,
5498                                  convert (ptr_type_node, integer_zero_node)));
5499       add_stmt (build_call_1_expr (reraise_zcx_decl, gnu_expr));
5500       gnat_poplevel ();
5501       gnu_result = end_stmt_group ();
5502       break;
5503
5504     case N_Push_Constraint_Error_Label:
5505       push_exception_label_stack (&gnu_constraint_error_label_stack,
5506                                   Exception_Label (gnat_node));
5507       break;
5508
5509     case N_Push_Storage_Error_Label:
5510       push_exception_label_stack (&gnu_storage_error_label_stack,
5511                                   Exception_Label (gnat_node));
5512       break;
5513
5514     case N_Push_Program_Error_Label:
5515       push_exception_label_stack (&gnu_program_error_label_stack,
5516                                   Exception_Label (gnat_node));
5517       break;
5518
5519     case N_Pop_Constraint_Error_Label:
5520       VEC_pop (tree, gnu_constraint_error_label_stack);
5521       break;
5522
5523     case N_Pop_Storage_Error_Label:
5524       VEC_pop (tree, gnu_storage_error_label_stack);
5525       break;
5526
5527     case N_Pop_Program_Error_Label:
5528       VEC_pop (tree, gnu_program_error_label_stack);
5529       break;
5530
5531     /******************************/
5532     /* Chapter 12: Generic Units  */
5533     /******************************/
5534
5535     case N_Generic_Function_Renaming_Declaration:
5536     case N_Generic_Package_Renaming_Declaration:
5537     case N_Generic_Procedure_Renaming_Declaration:
5538     case N_Generic_Package_Declaration:
5539     case N_Generic_Subprogram_Declaration:
5540     case N_Package_Instantiation:
5541     case N_Procedure_Instantiation:
5542     case N_Function_Instantiation:
5543       /* These nodes can appear on a declaration list but there is nothing to
5544          to be done with them.  */
5545       gnu_result = alloc_stmt_list ();
5546       break;
5547
5548     /**************************************************/
5549     /* Chapter 13: Representation Clauses and         */
5550     /*             Implementation-Dependent Features  */
5551     /**************************************************/
5552
5553     case N_Attribute_Definition_Clause:
5554       gnu_result = alloc_stmt_list ();
5555
5556       /* The only one we need to deal with is 'Address since, for the others,
5557          the front-end puts the information elsewhere.  */
5558       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
5559         break;
5560
5561       /* And we only deal with 'Address if the object has a Freeze node.  */
5562       gnat_temp = Entity (Name (gnat_node));
5563       if (No (Freeze_Node (gnat_temp)))
5564         break;
5565
5566       /* Get the value to use as the address and save it as the equivalent
5567          for the object.  When it is frozen, gnat_to_gnu_entity will do the
5568          right thing.  */
5569       save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
5570       break;
5571
5572     case N_Enumeration_Representation_Clause:
5573     case N_Record_Representation_Clause:
5574     case N_At_Clause:
5575       /* We do nothing with these.  SEM puts the information elsewhere.  */
5576       gnu_result = alloc_stmt_list ();
5577       break;
5578
5579     case N_Code_Statement:
5580       if (!type_annotate_only)
5581         {
5582           tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
5583           tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
5584           tree gnu_clobbers = NULL_TREE, tail;
5585           bool allows_mem, allows_reg, fake;
5586           int ninputs, noutputs, i;
5587           const char **oconstraints;
5588           const char *constraint;
5589           char *clobber;
5590
5591           /* First retrieve the 3 operand lists built by the front-end.  */
5592           Setup_Asm_Outputs (gnat_node);
5593           while (Present (gnat_temp = Asm_Output_Variable ()))
5594             {
5595               tree gnu_value = gnat_to_gnu (gnat_temp);
5596               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
5597                                                  (Asm_Output_Constraint ()));
5598
5599               gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
5600               Next_Asm_Output ();
5601             }
5602
5603           Setup_Asm_Inputs (gnat_node);
5604           while (Present (gnat_temp = Asm_Input_Value ()))
5605             {
5606               tree gnu_value = gnat_to_gnu (gnat_temp);
5607               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
5608                                                  (Asm_Input_Constraint ()));
5609
5610               gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
5611               Next_Asm_Input ();
5612             }
5613
5614           Clobber_Setup (gnat_node);
5615           while ((clobber = Clobber_Get_Next ()))
5616             gnu_clobbers
5617               = tree_cons (NULL_TREE,
5618                            build_string (strlen (clobber) + 1, clobber),
5619                            gnu_clobbers);
5620
5621           /* Then perform some standard checking and processing on the
5622              operands.  In particular, mark them addressable if needed.  */
5623           gnu_outputs = nreverse (gnu_outputs);
5624           noutputs = list_length (gnu_outputs);
5625           gnu_inputs = nreverse (gnu_inputs);
5626           ninputs = list_length (gnu_inputs);
5627           oconstraints = XALLOCAVEC (const char *, noutputs);
5628
5629           for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
5630             {
5631               tree output = TREE_VALUE (tail);
5632               constraint
5633                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
5634               oconstraints[i] = constraint;
5635
5636               if (parse_output_constraint (&constraint, i, ninputs, noutputs,
5637                                            &allows_mem, &allows_reg, &fake))
5638                 {
5639                   /* If the operand is going to end up in memory,
5640                      mark it addressable.  Note that we don't test
5641                      allows_mem like in the input case below; this
5642                      is modelled on the C front-end.  */
5643                   if (!allows_reg)
5644                     {
5645                       STRIP_NOPS (output);
5646                       if (TREE_CODE (output) == CONST_DECL
5647                           && DECL_CONST_CORRESPONDING_VAR (output))
5648                         output = DECL_CONST_CORRESPONDING_VAR (output);
5649                       if (!gnat_mark_addressable (output))
5650                         output = error_mark_node;
5651                     }
5652                 }
5653               else
5654                 output = error_mark_node;
5655
5656               TREE_VALUE (tail) = output;
5657             }
5658
5659           for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
5660             {
5661               tree input = TREE_VALUE (tail);
5662               constraint
5663                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
5664
5665               if (parse_input_constraint (&constraint, i, ninputs, noutputs,
5666                                           0, oconstraints,
5667                                           &allows_mem, &allows_reg))
5668                 {
5669                   /* If the operand is going to end up in memory,
5670                      mark it addressable.  */
5671                   if (!allows_reg && allows_mem)
5672                     {
5673                       STRIP_NOPS (input);
5674                       if (TREE_CODE (input) == CONST_DECL
5675                           && DECL_CONST_CORRESPONDING_VAR (input))
5676                         input = DECL_CONST_CORRESPONDING_VAR (input);
5677                       if (!gnat_mark_addressable (input))
5678                         input = error_mark_node;
5679                     }
5680                 }
5681               else
5682                 input = error_mark_node;
5683
5684               TREE_VALUE (tail) = input;
5685             }
5686
5687           gnu_result = build5 (ASM_EXPR,  void_type_node,
5688                                gnu_template, gnu_outputs,
5689                                gnu_inputs, gnu_clobbers, NULL_TREE);
5690           ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
5691         }
5692       else
5693         gnu_result = alloc_stmt_list ();
5694
5695       break;
5696
5697     /****************/
5698     /* Added Nodes  */
5699     /****************/
5700
5701     case N_Expression_With_Actions:
5702       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5703       /* This construct doesn't define a scope so we don't wrap the statement
5704          list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it
5705          from unsharing.  */
5706       gnu_result = build_stmt_group (Actions (gnat_node), false);
5707       gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
5708       TREE_SIDE_EFFECTS (gnu_result) = 1;
5709       gnu_expr = gnat_to_gnu (Expression (gnat_node));
5710       gnu_result
5711         = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
5712       break;
5713
5714     case N_Freeze_Entity:
5715       start_stmt_group ();
5716       process_freeze_entity (gnat_node);
5717       process_decls (Actions (gnat_node), Empty, Empty, true, true);
5718       gnu_result = end_stmt_group ();
5719       break;
5720
5721     case N_Itype_Reference:
5722       if (!present_gnu_tree (Itype (gnat_node)))
5723         process_type (Itype (gnat_node));
5724
5725       gnu_result = alloc_stmt_list ();
5726       break;
5727
5728     case N_Free_Statement:
5729       if (!type_annotate_only)
5730         {
5731           tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
5732           tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
5733           tree gnu_obj_type;
5734           tree gnu_actual_obj_type = 0;
5735           tree gnu_obj_size;
5736
5737           /* If this is a thin pointer, we must dereference it to create
5738              a fat pointer, then go back below to a thin pointer.  The
5739              reason for this is that we need a fat pointer someplace in
5740              order to properly compute the size.  */
5741           if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
5742             gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
5743                                       build_unary_op (INDIRECT_REF, NULL_TREE,
5744                                                       gnu_ptr));
5745
5746           /* If this is an unconstrained array, we know the object must
5747              have been allocated with the template in front of the object.
5748              So pass the template address, but get the total size.  Do this
5749              by converting to a thin pointer.  */
5750           if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
5751             gnu_ptr
5752               = convert (build_pointer_type
5753                          (TYPE_OBJECT_RECORD_TYPE
5754                           (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
5755                          gnu_ptr);
5756
5757           gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
5758
5759           if (Present (Actual_Designated_Subtype (gnat_node)))
5760             {
5761               gnu_actual_obj_type
5762                 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
5763
5764               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
5765                 gnu_actual_obj_type
5766                   = build_unc_object_type_from_ptr (gnu_ptr_type,
5767                                                     gnu_actual_obj_type,
5768                                                     get_identifier ("DEALLOC"),
5769                                                     false);
5770             }
5771           else
5772             gnu_actual_obj_type = gnu_obj_type;
5773
5774           gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
5775
5776           if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
5777               && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
5778             {
5779               tree gnu_char_ptr_type
5780                 = build_pointer_type (unsigned_char_type_node);
5781               tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
5782               gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
5783               gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
5784                                          gnu_ptr, gnu_pos);
5785             }
5786
5787           gnu_result
5788               = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
5789                                           Procedure_To_Call (gnat_node),
5790                                           Storage_Pool (gnat_node),
5791                                           gnat_node);
5792         }
5793       break;
5794
5795     case N_Raise_Constraint_Error:
5796     case N_Raise_Program_Error:
5797     case N_Raise_Storage_Error:
5798       {
5799         const int reason = UI_To_Int (Reason (gnat_node));
5800         const Node_Id cond = Condition (gnat_node);
5801         bool handled = false;
5802
5803         if (type_annotate_only)
5804           {
5805             gnu_result = alloc_stmt_list ();
5806             break;
5807           }
5808
5809         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5810
5811         if (Exception_Extra_Info
5812             && !No_Exception_Handlers_Set ()
5813             && !get_exception_label (kind)
5814             && TREE_CODE (gnu_result_type) == VOID_TYPE
5815             && Present (cond))
5816           {
5817             if (reason == CE_Access_Check_Failed)
5818               {
5819                 gnu_result = build_call_raise_column (reason, gnat_node);
5820                 handled = true;
5821               }
5822             else if ((reason == CE_Index_Check_Failed
5823                       || reason == CE_Range_Check_Failed
5824                       || reason == CE_Invalid_Data)
5825                      && Nkind (cond) == N_Op_Not
5826                      && Nkind (Right_Opnd (cond)) == N_In
5827                      && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range)
5828               {
5829                 Node_Id op = Right_Opnd (cond);  /* N_In node */
5830                 Node_Id index = Left_Opnd (op);
5831                 Node_Id type = Etype (index);
5832
5833                 if (Is_Type (type)
5834                     && Known_Esize (type)
5835                     && UI_To_Int (Esize (type)) <= 32)
5836                   {
5837                     Node_Id right_op = Right_Opnd (op);
5838                     gnu_result
5839                       = build_call_raise_range
5840                         (reason, gnat_node,
5841                          gnat_to_gnu (index),                  /* index */
5842                          gnat_to_gnu (Low_Bound (right_op)),   /* first */
5843                          gnat_to_gnu (High_Bound (right_op))); /* last  */
5844                     handled = true;
5845                   }
5846               }
5847           }
5848
5849         if (handled)
5850           {
5851             set_expr_location_from_node (gnu_result, gnat_node);
5852             gnu_result = build3 (COND_EXPR, void_type_node,
5853                                  gnat_to_gnu (cond),
5854                                  gnu_result, alloc_stmt_list ());
5855           }
5856         else
5857           {
5858             gnu_result = build_call_raise (reason, gnat_node, kind);
5859
5860             /* If the type is VOID, this is a statement, so we need to generate
5861                the code for the call.  Handle a Condition, if there is one.  */
5862             if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5863               {
5864                 set_expr_location_from_node (gnu_result, gnat_node);
5865                 if (Present (cond))
5866                   gnu_result = build3 (COND_EXPR, void_type_node,
5867                                        gnat_to_gnu (cond),
5868                                        gnu_result, alloc_stmt_list ());
5869               }
5870             else
5871               gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
5872           }
5873       }
5874       break;
5875
5876     case N_Validate_Unchecked_Conversion:
5877       {
5878         Entity_Id gnat_target_type = Target_Type (gnat_node);
5879         tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
5880         tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
5881
5882         /* No need for any warning in this case.  */
5883         if (!flag_strict_aliasing)
5884           ;
5885
5886         /* If the result is a pointer type, see if we are either converting
5887            from a non-pointer or from a pointer to a type with a different
5888            alias set and warn if so.  If the result is defined in the same
5889            unit as this unchecked conversion, we can allow this because we
5890            can know to make the pointer type behave properly.  */
5891         else if (POINTER_TYPE_P (gnu_target_type)
5892                  && !In_Same_Source_Unit (gnat_target_type, gnat_node)
5893                  && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
5894           {
5895             tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
5896                                          ? TREE_TYPE (gnu_source_type)
5897                                          : NULL_TREE;
5898             tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
5899
5900             if ((TYPE_DUMMY_P (gnu_target_desig_type)
5901                  || get_alias_set (gnu_target_desig_type) != 0)
5902                 && (!POINTER_TYPE_P (gnu_source_type)
5903                     || (TYPE_DUMMY_P (gnu_source_desig_type)
5904                         != TYPE_DUMMY_P (gnu_target_desig_type))
5905                     || (TYPE_DUMMY_P (gnu_source_desig_type)
5906                         && gnu_source_desig_type != gnu_target_desig_type)
5907                     || !alias_sets_conflict_p
5908                         (get_alias_set (gnu_source_desig_type),
5909                          get_alias_set (gnu_target_desig_type))))
5910               {
5911                 post_error_ne
5912                   ("?possible aliasing problem for type&",
5913                    gnat_node, Target_Type (gnat_node));
5914                 post_error
5915                   ("\\?use -fno-strict-aliasing switch for references",
5916                    gnat_node);
5917                 post_error_ne
5918                   ("\\?or use `pragma No_Strict_Aliasing (&);`",
5919                    gnat_node, Target_Type (gnat_node));
5920               }
5921           }
5922
5923         /* But if the result is a fat pointer type, we have no mechanism to
5924            do that, so we unconditionally warn in problematic cases.  */
5925         else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
5926           {
5927             tree gnu_source_array_type
5928               = TYPE_IS_FAT_POINTER_P (gnu_source_type)
5929                 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
5930                 : NULL_TREE;
5931             tree gnu_target_array_type
5932               = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
5933
5934             if ((TYPE_DUMMY_P (gnu_target_array_type)
5935                  || get_alias_set (gnu_target_array_type) != 0)
5936                 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
5937                     || (TYPE_DUMMY_P (gnu_source_array_type)
5938                         != TYPE_DUMMY_P (gnu_target_array_type))
5939                     || (TYPE_DUMMY_P (gnu_source_array_type)
5940                         && gnu_source_array_type != gnu_target_array_type)
5941                     || !alias_sets_conflict_p
5942                         (get_alias_set (gnu_source_array_type),
5943                          get_alias_set (gnu_target_array_type))))
5944               {
5945                 post_error_ne
5946                   ("?possible aliasing problem for type&",
5947                    gnat_node, Target_Type (gnat_node));
5948                 post_error
5949                   ("\\?use -fno-strict-aliasing switch for references",
5950                    gnat_node);
5951               }
5952           }
5953       }
5954       gnu_result = alloc_stmt_list ();
5955       break;
5956
5957     default:
5958       /* SCIL nodes require no processing for GCC.  Other nodes should only
5959          be present when annotating types.  */
5960       gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only);
5961       gnu_result = alloc_stmt_list ();
5962     }
5963
5964   /* If we pushed the processing of the elaboration routine, pop it back.  */
5965   if (went_into_elab_proc)
5966     current_function_decl = NULL_TREE;
5967
5968   /* When not optimizing, turn boolean rvalues B into B != false tests
5969      so that the code just below can put the location information of the
5970      reference to B on the inequality operator for better debug info.  */
5971   if (!optimize
5972       && TREE_CODE (gnu_result) != INTEGER_CST
5973       && (kind == N_Identifier
5974           || kind == N_Expanded_Name
5975           || kind == N_Explicit_Dereference
5976           || kind == N_Function_Call
5977           || kind == N_Indexed_Component
5978           || kind == N_Selected_Component)
5979       && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
5980       && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
5981     gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
5982                                   convert (gnu_result_type, gnu_result),
5983                                   convert (gnu_result_type,
5984                                            boolean_false_node));
5985
5986   /* Set the location information on the result.  Note that we may have
5987      no result if we tried to build a CALL_EXPR node to a procedure with
5988      no side-effects and optimization is enabled.  */
5989   if (gnu_result && EXPR_P (gnu_result))
5990     set_gnu_expr_location_from_node (gnu_result, gnat_node);
5991
5992   /* If we're supposed to return something of void_type, it means we have
5993      something we're elaborating for effect, so just return.  */
5994   if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5995     return gnu_result;
5996
5997   /* If the result is a constant that overflowed, raise Constraint_Error.  */
5998   if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
5999     {
6000       post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
6001       gnu_result
6002         = build1 (NULL_EXPR, gnu_result_type,
6003                   build_call_raise (CE_Overflow_Check_Failed, gnat_node,
6004                                     N_Raise_Constraint_Error));
6005     }
6006
6007   /* If our result has side-effects and is of an unconstrained type,
6008      make a SAVE_EXPR so that we can be sure it will only be referenced
6009      once.  Note we must do this before any conversions.  */
6010   if (TREE_SIDE_EFFECTS (gnu_result)
6011       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
6012           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
6013     gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
6014
6015   /* Now convert the result to the result type, unless we are in one of the
6016      following cases:
6017
6018        1. If this is the Name of an assignment statement or a parameter of
6019           a procedure call, return the result almost unmodified since the
6020           RHS will have to be converted to our type in that case, unless
6021           the result type has a simpler size.  Likewise if there is just
6022           a no-op unchecked conversion in-between.  Similarly, don't convert
6023           integral types that are the operands of an unchecked conversion
6024           since we need to ignore those conversions (for 'Valid).
6025
6026        2. If we have a label (which doesn't have any well-defined type), a
6027           field or an error, return the result almost unmodified.  Similarly,
6028           if the two types are record types with the same name, don't convert.
6029           This will be the case when we are converting from a packable version
6030           of a type to its original type and we need those conversions to be
6031           NOPs in order for assignments into these types to work properly.
6032
6033        3. If the type is void or if we have no result, return error_mark_node
6034           to show we have no result.
6035
6036        4. Finally, if the type of the result is already correct.  */
6037
6038   if (Present (Parent (gnat_node))
6039       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
6040            && Name (Parent (gnat_node)) == gnat_node)
6041           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
6042               && unchecked_conversion_nop (Parent (gnat_node)))
6043           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
6044               && Name (Parent (gnat_node)) != gnat_node)
6045           || Nkind (Parent (gnat_node)) == N_Parameter_Association
6046           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
6047               && !AGGREGATE_TYPE_P (gnu_result_type)
6048               && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
6049       && !(TYPE_SIZE (gnu_result_type)
6050            && TYPE_SIZE (TREE_TYPE (gnu_result))
6051            && (AGGREGATE_TYPE_P (gnu_result_type)
6052                == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
6053            && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
6054                 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
6055                     != INTEGER_CST))
6056                || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
6057                    && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
6058                    && (CONTAINS_PLACEHOLDER_P
6059                        (TYPE_SIZE (TREE_TYPE (gnu_result))))))
6060            && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
6061                 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
6062     {
6063       /* Remove padding only if the inner object is of self-referential
6064          size: in that case it must be an object of unconstrained type
6065          with a default discriminant and we want to avoid copying too
6066          much data.  */
6067       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
6068           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
6069                                      (TREE_TYPE (gnu_result))))))
6070         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
6071                               gnu_result);
6072     }
6073
6074   else if (TREE_CODE (gnu_result) == LABEL_DECL
6075            || TREE_CODE (gnu_result) == FIELD_DECL
6076            || TREE_CODE (gnu_result) == ERROR_MARK
6077            || (TYPE_NAME (gnu_result_type)
6078                == TYPE_NAME (TREE_TYPE (gnu_result))
6079                && TREE_CODE (gnu_result_type) == RECORD_TYPE
6080                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
6081     {
6082       /* Remove any padding.  */
6083       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
6084         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
6085                               gnu_result);
6086     }
6087
6088   else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
6089     gnu_result = error_mark_node;
6090
6091   else if (gnu_result_type != TREE_TYPE (gnu_result))
6092     gnu_result = convert (gnu_result_type, gnu_result);
6093
6094   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result.  */
6095   while ((TREE_CODE (gnu_result) == NOP_EXPR
6096           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
6097          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
6098     gnu_result = TREE_OPERAND (gnu_result, 0);
6099
6100   return gnu_result;
6101 }
6102 \f
6103 /* Subroutine of above to push the exception label stack.  GNU_STACK is
6104    a pointer to the stack to update and GNAT_LABEL, if present, is the
6105    label to push onto the stack.  */
6106
6107 static void
6108 push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label)
6109 {
6110   tree gnu_label = (Present (gnat_label)
6111                     ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
6112                     : NULL_TREE);
6113
6114   VEC_safe_push (tree, gc, *gnu_stack, gnu_label);
6115 }
6116 \f
6117 /* Record the current code position in GNAT_NODE.  */
6118
6119 static void
6120 record_code_position (Node_Id gnat_node)
6121 {
6122   tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
6123
6124   add_stmt_with_node (stmt_stmt, gnat_node);
6125   save_gnu_tree (gnat_node, stmt_stmt, true);
6126 }
6127
6128 /* Insert the code for GNAT_NODE at the position saved for that node.  */
6129
6130 static void
6131 insert_code_for (Node_Id gnat_node)
6132 {
6133   STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
6134   save_gnu_tree (gnat_node, NULL_TREE, true);
6135 }
6136 \f
6137 /* Start a new statement group chained to the previous group.  */
6138
6139 void
6140 start_stmt_group (void)
6141 {
6142   struct stmt_group *group = stmt_group_free_list;
6143
6144   /* First see if we can get one from the free list.  */
6145   if (group)
6146     stmt_group_free_list = group->previous;
6147   else
6148     group = ggc_alloc_stmt_group ();
6149
6150   group->previous = current_stmt_group;
6151   group->stmt_list = group->block = group->cleanups = NULL_TREE;
6152   current_stmt_group = group;
6153 }
6154
6155 /* Add GNU_STMT to the current statement group.  If it is an expression with
6156    no effects, it is ignored.  */
6157
6158 void
6159 add_stmt (tree gnu_stmt)
6160 {
6161   append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
6162 }
6163
6164 /* Similar, but the statement is always added, regardless of side-effects.  */
6165
6166 void
6167 add_stmt_force (tree gnu_stmt)
6168 {
6169   append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
6170 }
6171
6172 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE.  */
6173
6174 void
6175 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
6176 {
6177   if (Present (gnat_node))
6178     set_expr_location_from_node (gnu_stmt, gnat_node);
6179   add_stmt (gnu_stmt);
6180 }
6181
6182 /* Similar, but the statement is always added, regardless of side-effects.  */
6183
6184 void
6185 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
6186 {
6187   if (Present (gnat_node))
6188     set_expr_location_from_node (gnu_stmt, gnat_node);
6189   add_stmt_force (gnu_stmt);
6190 }
6191
6192 /* Add a declaration statement for GNU_DECL to the current statement group.
6193    Get SLOC from Entity_Id.  */
6194
6195 void
6196 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
6197 {
6198   tree type = TREE_TYPE (gnu_decl);
6199   tree gnu_stmt, gnu_init, t;
6200
6201   /* If this is a variable that Gigi is to ignore, we may have been given
6202      an ERROR_MARK.  So test for it.  We also might have been given a
6203      reference for a renaming.  So only do something for a decl.  Also
6204      ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE.  */
6205   if (!DECL_P (gnu_decl)
6206       || (TREE_CODE (gnu_decl) == TYPE_DECL
6207           && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
6208     return;
6209
6210   gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
6211
6212   /* If we are global, we don't want to actually output the DECL_EXPR for
6213      this decl since we already have evaluated the expressions in the
6214      sizes and positions as globals and doing it again would be wrong.  */
6215   if (global_bindings_p ())
6216     {
6217       /* Mark everything as used to prevent node sharing with subprograms.
6218          Note that walk_tree knows how to deal with TYPE_DECL, but neither
6219          VAR_DECL nor CONST_DECL.  This appears to be somewhat arbitrary.  */
6220       MARK_VISITED (gnu_stmt);
6221       if (TREE_CODE (gnu_decl) == VAR_DECL
6222           || TREE_CODE (gnu_decl) == CONST_DECL)
6223         {
6224           MARK_VISITED (DECL_SIZE (gnu_decl));
6225           MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
6226           MARK_VISITED (DECL_INITIAL (gnu_decl));
6227         }
6228       /* In any case, we have to deal with our own TYPE_ADA_SIZE field.  */
6229       else if (TREE_CODE (gnu_decl) == TYPE_DECL
6230                && ((TREE_CODE (type) == RECORD_TYPE
6231                     && !TYPE_FAT_POINTER_P (type))
6232                    || TREE_CODE (type) == UNION_TYPE
6233                    || TREE_CODE (type) == QUAL_UNION_TYPE))
6234         MARK_VISITED (TYPE_ADA_SIZE (type));
6235     }
6236   else if (!DECL_EXTERNAL (gnu_decl))
6237     add_stmt_with_node (gnu_stmt, gnat_entity);
6238
6239   /* If this is a variable and an initializer is attached to it, it must be
6240      valid for the context.  Similar to init_const in create_var_decl_1.  */
6241   if (TREE_CODE (gnu_decl) == VAR_DECL
6242       && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
6243       && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
6244           || (TREE_STATIC (gnu_decl)
6245               && !initializer_constant_valid_p (gnu_init,
6246                                                 TREE_TYPE (gnu_init)))))
6247     {
6248       /* If GNU_DECL has a padded type, convert it to the unpadded
6249          type so the assignment is done properly.  */
6250       if (TYPE_IS_PADDING_P (type))
6251         t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
6252       else
6253         t = gnu_decl;
6254
6255       gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
6256
6257       DECL_INITIAL (gnu_decl) = NULL_TREE;
6258       if (TREE_READONLY (gnu_decl))
6259         {
6260           TREE_READONLY (gnu_decl) = 0;
6261           DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
6262         }
6263
6264       add_stmt_with_node (gnu_stmt, gnat_entity);
6265     }
6266 }
6267
6268 /* Callback for walk_tree to mark the visited trees rooted at *TP.  */
6269
6270 static tree
6271 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
6272 {
6273   tree t = *tp;
6274
6275   if (TREE_VISITED (t))
6276     *walk_subtrees = 0;
6277
6278   /* Don't mark a dummy type as visited because we want to mark its sizes
6279      and fields once it's filled in.  */
6280   else if (!TYPE_IS_DUMMY_P (t))
6281     TREE_VISITED (t) = 1;
6282
6283   if (TYPE_P (t))
6284     TYPE_SIZES_GIMPLIFIED (t) = 1;
6285
6286   return NULL_TREE;
6287 }
6288
6289 /* Mark nodes rooted at T with TREE_VISITED and types as having their
6290    sized gimplified.  We use this to indicate all variable sizes and
6291    positions in global types may not be shared by any subprogram.  */
6292
6293 void
6294 mark_visited (tree t)
6295 {
6296   walk_tree (&t, mark_visited_r, NULL, NULL);
6297 }
6298
6299 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
6300    set its location to that of GNAT_NODE if present.  */
6301
6302 static void
6303 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
6304 {
6305   if (Present (gnat_node))
6306     set_expr_location_from_node (gnu_cleanup, gnat_node);
6307   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
6308 }
6309
6310 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
6311
6312 void
6313 set_block_for_group (tree gnu_block)
6314 {
6315   gcc_assert (!current_stmt_group->block);
6316   current_stmt_group->block = gnu_block;
6317 }
6318
6319 /* Return code corresponding to the current code group.  It is normally
6320    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
6321    BLOCK or cleanups were set.  */
6322
6323 tree
6324 end_stmt_group (void)
6325 {
6326   struct stmt_group *group = current_stmt_group;
6327   tree gnu_retval = group->stmt_list;
6328
6329   /* If this is a null list, allocate a new STATEMENT_LIST.  Then, if there
6330      are cleanups, make a TRY_FINALLY_EXPR.  Last, if there is a BLOCK,
6331      make a BIND_EXPR.  Note that we nest in that because the cleanup may
6332      reference variables in the block.  */
6333   if (gnu_retval == NULL_TREE)
6334     gnu_retval = alloc_stmt_list ();
6335
6336   if (group->cleanups)
6337     gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
6338                          group->cleanups);
6339
6340   if (current_stmt_group->block)
6341     gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
6342                          gnu_retval, group->block);
6343
6344   /* Remove this group from the stack and add it to the free list.  */
6345   current_stmt_group = group->previous;
6346   group->previous = stmt_group_free_list;
6347   stmt_group_free_list = group;
6348
6349   return gnu_retval;
6350 }
6351
6352 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
6353    statements.*/
6354
6355 static void
6356 add_stmt_list (List_Id gnat_list)
6357 {
6358   Node_Id gnat_node;
6359
6360   if (Present (gnat_list))
6361     for (gnat_node = First (gnat_list); Present (gnat_node);
6362          gnat_node = Next (gnat_node))
6363       add_stmt (gnat_to_gnu (gnat_node));
6364 }
6365
6366 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
6367    If BINDING_P is true, push and pop a binding level around the list.  */
6368
6369 static tree
6370 build_stmt_group (List_Id gnat_list, bool binding_p)
6371 {
6372   start_stmt_group ();
6373   if (binding_p)
6374     gnat_pushlevel ();
6375
6376   add_stmt_list (gnat_list);
6377   if (binding_p)
6378     gnat_poplevel ();
6379
6380   return end_stmt_group ();
6381 }
6382 \f
6383 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
6384
6385 int
6386 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
6387                     gimple_seq *post_p ATTRIBUTE_UNUSED)
6388 {
6389   tree expr = *expr_p;
6390   tree op;
6391
6392   if (IS_ADA_STMT (expr))
6393     return gnat_gimplify_stmt (expr_p);
6394
6395   switch (TREE_CODE (expr))
6396     {
6397     case NULL_EXPR:
6398       /* If this is for a scalar, just make a VAR_DECL for it.  If for
6399          an aggregate, get a null pointer of the appropriate type and
6400          dereference it.  */
6401       if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
6402         *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
6403                           convert (build_pointer_type (TREE_TYPE (expr)),
6404                                    integer_zero_node));
6405       else
6406         {
6407           *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
6408           TREE_NO_WARNING (*expr_p) = 1;
6409         }
6410
6411       gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
6412       return GS_OK;
6413
6414     case UNCONSTRAINED_ARRAY_REF:
6415       /* We should only do this if we are just elaborating for side-effects,
6416          but we can't know that yet.  */
6417       *expr_p = TREE_OPERAND (*expr_p, 0);
6418       return GS_OK;
6419
6420     case ADDR_EXPR:
6421       op = TREE_OPERAND (expr, 0);
6422
6423       /* If we are taking the address of a constant CONSTRUCTOR, make sure it
6424          is put into static memory.  We know that it's going to be read-only
6425          given the semantics we have and it must be in static memory when the
6426          reference is in an elaboration procedure.  */
6427       if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
6428         {
6429           tree addr = build_fold_addr_expr (tree_output_constant_def (op));
6430           *expr_p = fold_convert (TREE_TYPE (expr), addr);
6431           return GS_ALL_DONE;
6432         }
6433
6434       /* Otherwise, if we are taking the address of a non-constant CONSTRUCTOR
6435          or of a call, explicitly create the local temporary.  That's required
6436          if the type is passed by reference.  */
6437       if (TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
6438         {
6439           tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
6440           TREE_ADDRESSABLE (new_var) = 1;
6441           gimple_add_tmp_var (new_var);
6442
6443           mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
6444           gimplify_and_add (mod, pre_p);
6445
6446           TREE_OPERAND (expr, 0) = new_var;
6447           recompute_tree_invariant_for_addr_expr (expr);
6448           return GS_ALL_DONE;
6449         }
6450
6451       return GS_UNHANDLED;
6452
6453     case DECL_EXPR:
6454       op = DECL_EXPR_DECL (expr);
6455
6456       /* The expressions for the RM bounds must be gimplified to ensure that
6457          they are properly elaborated.  See gimplify_decl_expr.  */
6458       if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
6459           && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
6460         switch (TREE_CODE (TREE_TYPE (op)))
6461           {
6462           case INTEGER_TYPE:
6463           case ENUMERAL_TYPE:
6464           case BOOLEAN_TYPE:
6465           case REAL_TYPE:
6466             {
6467               tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
6468
6469               val = TYPE_RM_MIN_VALUE (type);
6470               if (val)
6471                 {
6472                   gimplify_one_sizepos (&val, pre_p);
6473                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
6474                     SET_TYPE_RM_MIN_VALUE (t, val);
6475                 }
6476
6477               val = TYPE_RM_MAX_VALUE (type);
6478               if (val)
6479                 {
6480                   gimplify_one_sizepos (&val, pre_p);
6481                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
6482                     SET_TYPE_RM_MAX_VALUE (t, val);
6483                 }
6484
6485             }
6486             break;
6487
6488           default:
6489             break;
6490           }
6491
6492       /* ... fall through ... */
6493
6494     default:
6495       return GS_UNHANDLED;
6496     }
6497 }
6498
6499 /* Generate GIMPLE in place for the statement at *STMT_P.  */
6500
6501 static enum gimplify_status
6502 gnat_gimplify_stmt (tree *stmt_p)
6503 {
6504   tree stmt = *stmt_p;
6505
6506   switch (TREE_CODE (stmt))
6507     {
6508     case STMT_STMT:
6509       *stmt_p = STMT_STMT_STMT (stmt);
6510       return GS_OK;
6511
6512     case LOOP_STMT:
6513       {
6514         tree gnu_start_label = create_artificial_label (input_location);
6515         tree gnu_cond = LOOP_STMT_COND (stmt);
6516         tree gnu_update = LOOP_STMT_UPDATE (stmt);
6517         tree gnu_end_label = LOOP_STMT_LABEL (stmt);
6518         tree t;
6519
6520         /* Build the condition expression from the test, if any.  */
6521         if (gnu_cond)
6522           gnu_cond
6523             = build3 (COND_EXPR, void_type_node, gnu_cond, alloc_stmt_list (),
6524                       build1 (GOTO_EXPR, void_type_node, gnu_end_label));
6525
6526         /* Set to emit the statements of the loop.  */
6527         *stmt_p = NULL_TREE;
6528
6529         /* We first emit the start label and then a conditional jump to the
6530            end label if there's a top condition, then the update if it's at
6531            the top, then the body of the loop, then a conditional jump to
6532            the end label if there's a bottom condition, then the update if
6533            it's at the bottom, and finally a jump to the start label and the
6534            definition of the end label.  */
6535         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
6536                                           gnu_start_label),
6537                                   stmt_p);
6538
6539         if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
6540           append_to_statement_list (gnu_cond, stmt_p);
6541
6542         if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
6543           append_to_statement_list (gnu_update, stmt_p);
6544
6545         append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
6546
6547         if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
6548           append_to_statement_list (gnu_cond, stmt_p);
6549
6550         if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
6551           append_to_statement_list (gnu_update, stmt_p);
6552
6553         t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
6554         SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
6555         append_to_statement_list (t, stmt_p);
6556
6557         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
6558                                           gnu_end_label),
6559                                   stmt_p);
6560         return GS_OK;
6561       }
6562
6563     case EXIT_STMT:
6564       /* Build a statement to jump to the corresponding end label, then
6565          see if it needs to be conditional.  */
6566       *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
6567       if (EXIT_STMT_COND (stmt))
6568         *stmt_p = build3 (COND_EXPR, void_type_node,
6569                           EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
6570       return GS_OK;
6571
6572     default:
6573       gcc_unreachable ();
6574     }
6575 }
6576 \f
6577 /* Force references to each of the entities in packages withed by GNAT_NODE.
6578    Operate recursively but check that we aren't elaborating something more
6579    than once.
6580
6581    This routine is exclusively called in type_annotate mode, to compute DDA
6582    information for types in withed units, for ASIS use.  */
6583
6584 static void
6585 elaborate_all_entities (Node_Id gnat_node)
6586 {
6587   Entity_Id gnat_with_clause, gnat_entity;
6588
6589   /* Process each unit only once.  As we trace the context of all relevant
6590      units transitively, including generic bodies, we may encounter the
6591      same generic unit repeatedly.  */
6592   if (!present_gnu_tree (gnat_node))
6593      save_gnu_tree (gnat_node, integer_zero_node, true);
6594
6595   /* Save entities in all context units.  A body may have an implicit_with
6596      on its own spec, if the context includes a child unit, so don't save
6597      the spec twice.  */
6598   for (gnat_with_clause = First (Context_Items (gnat_node));
6599        Present (gnat_with_clause);
6600        gnat_with_clause = Next (gnat_with_clause))
6601     if (Nkind (gnat_with_clause) == N_With_Clause
6602         && !present_gnu_tree (Library_Unit (gnat_with_clause))
6603         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
6604       {
6605         elaborate_all_entities (Library_Unit (gnat_with_clause));
6606
6607         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
6608           {
6609             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
6610                  Present (gnat_entity);
6611                  gnat_entity = Next_Entity (gnat_entity))
6612               if (Is_Public (gnat_entity)
6613                   && Convention (gnat_entity) != Convention_Intrinsic
6614                   && Ekind (gnat_entity) != E_Package
6615                   && Ekind (gnat_entity) != E_Package_Body
6616                   && Ekind (gnat_entity) != E_Operator
6617                   && !(IN (Ekind (gnat_entity), Type_Kind)
6618                        && !Is_Frozen (gnat_entity))
6619                   && !((Ekind (gnat_entity) == E_Procedure
6620                         || Ekind (gnat_entity) == E_Function)
6621                        && Is_Intrinsic_Subprogram (gnat_entity))
6622                   && !IN (Ekind (gnat_entity), Named_Kind)
6623                   && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
6624                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
6625           }
6626         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
6627           {
6628             Node_Id gnat_body
6629               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
6630
6631             /* Retrieve compilation unit node of generic body.  */
6632             while (Present (gnat_body)
6633                    && Nkind (gnat_body) != N_Compilation_Unit)
6634               gnat_body = Parent (gnat_body);
6635
6636             /* If body is available, elaborate its context.  */
6637             if (Present (gnat_body))
6638               elaborate_all_entities (gnat_body);
6639           }
6640       }
6641
6642   if (Nkind (Unit (gnat_node)) == N_Package_Body)
6643     elaborate_all_entities (Library_Unit (gnat_node));
6644 }
6645 \f
6646 /* Do the processing of GNAT_NODE, an N_Freeze_Entity.  */
6647
6648 static void
6649 process_freeze_entity (Node_Id gnat_node)
6650 {
6651   const Entity_Id gnat_entity = Entity (gnat_node);
6652   const Entity_Kind kind = Ekind (gnat_entity);
6653   tree gnu_old, gnu_new;
6654
6655   /* If this is a package, we need to generate code for the package.  */
6656   if (kind == E_Package)
6657     {
6658       insert_code_for
6659         (Parent (Corresponding_Body
6660                  (Parent (Declaration_Node (gnat_entity)))));
6661       return;
6662     }
6663
6664   /* Don't do anything for class-wide types as they are always transformed
6665      into their root type.  */
6666   if (kind == E_Class_Wide_Type)
6667     return;
6668
6669   /* Check for an old definition.  This freeze node might be for an Itype.  */
6670   gnu_old
6671     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
6672
6673   /* If this entity has an address representation clause, GNU_OLD is the
6674      address, so discard it here.  */
6675   if (Present (Address_Clause (gnat_entity)))
6676     gnu_old = NULL_TREE;
6677
6678   /* Don't do anything for subprograms that may have been elaborated before
6679      their freeze nodes.  This can happen, for example, because of an inner
6680      call in an instance body or because of previous compilation of a spec
6681      for inlining purposes.  */
6682   if (gnu_old
6683       && ((TREE_CODE (gnu_old) == FUNCTION_DECL
6684            && (kind == E_Function || kind == E_Procedure))
6685           || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
6686               && kind == E_Subprogram_Type)))
6687     return;
6688
6689   /* If we have a non-dummy type old tree, we have nothing to do, except
6690      aborting if this is the public view of a private type whose full view was
6691      not delayed, as this node was never delayed as it should have been.  We
6692      let this happen for concurrent types and their Corresponding_Record_Type,
6693      however, because each might legitimately be elaborated before its own
6694      freeze node, e.g. while processing the other.  */
6695   if (gnu_old
6696       && !(TREE_CODE (gnu_old) == TYPE_DECL
6697            && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
6698     {
6699       gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
6700                    && Present (Full_View (gnat_entity))
6701                    && No (Freeze_Node (Full_View (gnat_entity))))
6702                   || Is_Concurrent_Type (gnat_entity)
6703                   || (IN (kind, Record_Kind)
6704                       && Is_Concurrent_Record_Type (gnat_entity)));
6705       return;
6706     }
6707
6708   /* Reset the saved tree, if any, and elaborate the object or type for real.
6709      If there is a full view, elaborate it and use the result.  And, if this
6710      is the root type of a class-wide type, reuse it for the latter.  */
6711   if (gnu_old)
6712     {
6713       save_gnu_tree (gnat_entity, NULL_TREE, false);
6714       if (IN (kind, Incomplete_Or_Private_Kind)
6715           && Present (Full_View (gnat_entity))
6716           && present_gnu_tree (Full_View (gnat_entity)))
6717         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
6718       if (IN (kind, Type_Kind)
6719           && Present (Class_Wide_Type (gnat_entity))
6720           && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6721         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
6722     }
6723
6724   if (IN (kind, Incomplete_Or_Private_Kind)
6725       && Present (Full_View (gnat_entity)))
6726     {
6727       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
6728
6729       /* Propagate back-annotations from full view to partial view.  */
6730       if (Unknown_Alignment (gnat_entity))
6731         Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
6732
6733       if (Unknown_Esize (gnat_entity))
6734         Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
6735
6736       if (Unknown_RM_Size (gnat_entity))
6737         Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
6738
6739       /* The above call may have defined this entity (the simplest example
6740          of this is when we have a private enumeral type since the bounds
6741          will have the public view).  */
6742       if (!present_gnu_tree (gnat_entity))
6743         save_gnu_tree (gnat_entity, gnu_new, false);
6744     }
6745   else
6746     {
6747       tree gnu_init
6748         = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
6749            && present_gnu_tree (Declaration_Node (gnat_entity)))
6750           ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
6751
6752       gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
6753     }
6754
6755   if (IN (kind, Type_Kind)
6756       && Present (Class_Wide_Type (gnat_entity))
6757       && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6758     save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
6759
6760   /* If we have an old type and we've made pointers to this type, update those
6761      pointers.  If this is a Taft amendment type in the main unit, we need to
6762      mark the type as used since other units referencing it don't see the full
6763      declaration and, therefore, cannot mark it as used themselves.  */
6764   if (gnu_old)
6765     {
6766       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
6767                          TREE_TYPE (gnu_new));
6768       if (DECL_TAFT_TYPE_P (gnu_old))
6769         used_types_insert (TREE_TYPE (gnu_new));
6770     }
6771 }
6772 \f
6773 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
6774    We make two passes, one to elaborate anything other than bodies (but
6775    we declare a function if there was no spec).  The second pass
6776    elaborates the bodies.
6777
6778    GNAT_END_LIST gives the element in the list past the end.  Normally,
6779    this is Empty, but can be First_Real_Statement for a
6780    Handled_Sequence_Of_Statements.
6781
6782    We make a complete pass through both lists if PASS1P is true, then make
6783    the second pass over both lists if PASS2P is true.  The lists usually
6784    correspond to the public and private parts of a package.  */
6785
6786 static void
6787 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
6788                Node_Id gnat_end_list, bool pass1p, bool pass2p)
6789 {
6790   List_Id gnat_decl_array[2];
6791   Node_Id gnat_decl;
6792   int i;
6793
6794   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
6795
6796   if (pass1p)
6797     for (i = 0; i <= 1; i++)
6798       if (Present (gnat_decl_array[i]))
6799         for (gnat_decl = First (gnat_decl_array[i]);
6800              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6801           {
6802             /* For package specs, we recurse inside the declarations,
6803                thus taking the two pass approach inside the boundary.  */
6804             if (Nkind (gnat_decl) == N_Package_Declaration
6805                 && (Nkind (Specification (gnat_decl)
6806                            == N_Package_Specification)))
6807               process_decls (Visible_Declarations (Specification (gnat_decl)),
6808                              Private_Declarations (Specification (gnat_decl)),
6809                              Empty, true, false);
6810
6811             /* Similarly for any declarations in the actions of a
6812                freeze node.  */
6813             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6814               {
6815                 process_freeze_entity (gnat_decl);
6816                 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
6817               }
6818
6819             /* Package bodies with freeze nodes get their elaboration deferred
6820                until the freeze node, but the code must be placed in the right
6821                place, so record the code position now.  */
6822             else if (Nkind (gnat_decl) == N_Package_Body
6823                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
6824               record_code_position (gnat_decl);
6825
6826             else if (Nkind (gnat_decl) == N_Package_Body_Stub
6827                      && Present (Library_Unit (gnat_decl))
6828                      && Present (Freeze_Node
6829                                  (Corresponding_Spec
6830                                   (Proper_Body (Unit
6831                                                 (Library_Unit (gnat_decl)))))))
6832               record_code_position
6833                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
6834
6835             /* We defer most subprogram bodies to the second pass.  */
6836             else if (Nkind (gnat_decl) == N_Subprogram_Body)
6837               {
6838                 if (Acts_As_Spec (gnat_decl))
6839                   {
6840                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
6841
6842                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
6843                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6844                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6845                   }
6846               }
6847
6848             /* For bodies and stubs that act as their own specs, the entity
6849                itself must be elaborated in the first pass, because it may
6850                be used in other declarations.  */
6851             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
6852               {
6853                 Node_Id gnat_subprog_id
6854                   = Defining_Entity (Specification (gnat_decl));
6855
6856                     if (Ekind (gnat_subprog_id) != E_Subprogram_Body
6857                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
6858                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6859                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6860               }
6861
6862             /* Concurrent stubs stand for the corresponding subprogram bodies,
6863                which are deferred like other bodies.  */
6864             else if (Nkind (gnat_decl) == N_Task_Body_Stub
6865                      || Nkind (gnat_decl) == N_Protected_Body_Stub)
6866               ;
6867
6868             else
6869               add_stmt (gnat_to_gnu (gnat_decl));
6870           }
6871
6872   /* Here we elaborate everything we deferred above except for package bodies,
6873      which are elaborated at their freeze nodes.  Note that we must also
6874      go inside things (package specs and freeze nodes) the first pass did.  */
6875   if (pass2p)
6876     for (i = 0; i <= 1; i++)
6877       if (Present (gnat_decl_array[i]))
6878         for (gnat_decl = First (gnat_decl_array[i]);
6879              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6880           {
6881             if (Nkind (gnat_decl) == N_Subprogram_Body
6882                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
6883                 || Nkind (gnat_decl) == N_Task_Body_Stub
6884                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
6885               add_stmt (gnat_to_gnu (gnat_decl));
6886
6887             else if (Nkind (gnat_decl) == N_Package_Declaration
6888                      && (Nkind (Specification (gnat_decl)
6889                                 == N_Package_Specification)))
6890               process_decls (Visible_Declarations (Specification (gnat_decl)),
6891                              Private_Declarations (Specification (gnat_decl)),
6892                              Empty, false, true);
6893
6894             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6895               process_decls (Actions (gnat_decl), Empty, Empty, false, true);
6896           }
6897 }
6898 \f
6899 /* Make a unary operation of kind CODE using build_unary_op, but guard
6900    the operation by an overflow check.  CODE can be one of NEGATE_EXPR
6901    or ABS_EXPR.  GNU_TYPE is the type desired for the result.  Usually
6902    the operation is to be performed in that type.  GNAT_NODE is the gnat
6903    node conveying the source location for which the error should be
6904    signaled.  */
6905
6906 static tree
6907 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
6908                       Node_Id gnat_node)
6909 {
6910   gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
6911
6912   operand = gnat_protect_expr (operand);
6913
6914   return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
6915                                       operand, TYPE_MIN_VALUE (gnu_type)),
6916                      build_unary_op (code, gnu_type, operand),
6917                      CE_Overflow_Check_Failed, gnat_node);
6918 }
6919
6920 /* Make a binary operation of kind CODE using build_binary_op, but guard
6921    the operation by an overflow check.  CODE can be one of PLUS_EXPR,
6922    MINUS_EXPR or MULT_EXPR.  GNU_TYPE is the type desired for the result.
6923    Usually the operation is to be performed in that type.  GNAT_NODE is
6924    the GNAT node conveying the source location for which the error should
6925    be signaled.  */
6926
6927 static tree
6928 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
6929                        tree right, Node_Id gnat_node)
6930 {
6931   tree lhs = gnat_protect_expr (left);
6932   tree rhs = gnat_protect_expr (right);
6933   tree type_max = TYPE_MAX_VALUE (gnu_type);
6934   tree type_min = TYPE_MIN_VALUE (gnu_type);
6935   tree gnu_expr;
6936   tree tmp1, tmp2;
6937   tree zero = convert (gnu_type, integer_zero_node);
6938   tree rhs_lt_zero;
6939   tree check_pos;
6940   tree check_neg;
6941   tree check;
6942   int precision = TYPE_PRECISION (gnu_type);
6943
6944   gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */
6945
6946   /* Prefer a constant or known-positive rhs to simplify checks.  */
6947   if (!TREE_CONSTANT (rhs)
6948       && commutative_tree_code (code)
6949       && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs)
6950                                   && tree_expr_nonnegative_p (lhs))))
6951     {
6952       tree tmp = lhs;
6953       lhs = rhs;
6954       rhs = tmp;
6955     }
6956
6957   rhs_lt_zero = tree_expr_nonnegative_p (rhs)
6958                 ? boolean_false_node
6959                 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
6960
6961   /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
6962
6963   /* Try a few strategies that may be cheaper than the general
6964      code at the end of the function, if the rhs is not known.
6965      The strategies are:
6966        - Call library function for 64-bit multiplication (complex)
6967        - Widen, if input arguments are sufficiently small
6968        - Determine overflow using wrapped result for addition/subtraction.  */
6969
6970   if (!TREE_CONSTANT (rhs))
6971     {
6972       /* Even for add/subtract double size to get another base type.  */
6973       int needed_precision = precision * 2;
6974
6975       if (code == MULT_EXPR && precision == 64)
6976         {
6977           tree int_64 = gnat_type_for_size (64, 0);
6978
6979           return convert (gnu_type, build_call_2_expr (mulv64_decl,
6980                                                        convert (int_64, lhs),
6981                                                        convert (int_64, rhs)));
6982         }
6983
6984       else if (needed_precision <= BITS_PER_WORD
6985                || (code == MULT_EXPR
6986                    && needed_precision <= LONG_LONG_TYPE_SIZE))
6987         {
6988           tree wide_type = gnat_type_for_size (needed_precision, 0);
6989
6990           tree wide_result = build_binary_op (code, wide_type,
6991                                               convert (wide_type, lhs),
6992                                               convert (wide_type, rhs));
6993
6994           tree check = build_binary_op
6995             (TRUTH_ORIF_EXPR, boolean_type_node,
6996              build_binary_op (LT_EXPR, boolean_type_node, wide_result,
6997                               convert (wide_type, type_min)),
6998              build_binary_op (GT_EXPR, boolean_type_node, wide_result,
6999                               convert (wide_type, type_max)));
7000
7001           tree result = convert (gnu_type, wide_result);
7002
7003           return
7004             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
7005         }
7006
7007       else if (code == PLUS_EXPR || code == MINUS_EXPR)
7008         {
7009           tree unsigned_type = gnat_type_for_size (precision, 1);
7010           tree wrapped_expr = convert
7011             (gnu_type, build_binary_op (code, unsigned_type,
7012                                         convert (unsigned_type, lhs),
7013                                         convert (unsigned_type, rhs)));
7014
7015           tree result = convert
7016             (gnu_type, build_binary_op (code, gnu_type, lhs, rhs));
7017
7018           /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
7019              or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction.  */
7020           tree check = build_binary_op
7021             (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
7022              build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
7023                               boolean_type_node, wrapped_expr, lhs));
7024
7025           return
7026             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
7027         }
7028    }
7029
7030   switch (code)
7031     {
7032     case PLUS_EXPR:
7033       /* When rhs >= 0, overflow when lhs > type_max - rhs.  */
7034       check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
7035                                    build_binary_op (MINUS_EXPR, gnu_type,
7036                                                     type_max, rhs)),
7037
7038       /* When rhs < 0, overflow when lhs < type_min - rhs.  */
7039       check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
7040                                    build_binary_op (MINUS_EXPR, gnu_type,
7041                                                     type_min, rhs));
7042       break;
7043
7044     case MINUS_EXPR:
7045       /* When rhs >= 0, overflow when lhs < type_min + rhs.  */
7046       check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
7047                                    build_binary_op (PLUS_EXPR, gnu_type,
7048                                                     type_min, rhs)),
7049
7050       /* When rhs < 0, overflow when lhs > type_max + rhs.  */
7051       check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
7052                                    build_binary_op (PLUS_EXPR, gnu_type,
7053                                                     type_max, rhs));
7054       break;
7055
7056     case MULT_EXPR:
7057       /* The check here is designed to be efficient if the rhs is constant,
7058          but it will work for any rhs by using integer division.
7059          Four different check expressions determine whether X * C overflows,
7060          depending on C.
7061            C ==  0  =>  false
7062            C  >  0  =>  X > type_max / C || X < type_min / C
7063            C == -1  =>  X == type_min
7064            C  < -1  =>  X > type_min / C || X < type_max / C */
7065
7066       tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
7067       tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
7068
7069       check_pos
7070         = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
7071                            build_binary_op (NE_EXPR, boolean_type_node, zero,
7072                                             rhs),
7073                            build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7074                                             build_binary_op (GT_EXPR,
7075                                                              boolean_type_node,
7076                                                              lhs, tmp1),
7077                                             build_binary_op (LT_EXPR,
7078                                                              boolean_type_node,
7079                                                              lhs, tmp2)));
7080
7081       check_neg
7082         = fold_build3 (COND_EXPR, boolean_type_node,
7083                        build_binary_op (EQ_EXPR, boolean_type_node, rhs,
7084                                         build_int_cst (gnu_type, -1)),
7085                        build_binary_op (EQ_EXPR, boolean_type_node, lhs,
7086                                         type_min),
7087                        build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7088                                         build_binary_op (GT_EXPR,
7089                                                          boolean_type_node,
7090                                                          lhs, tmp2),
7091                                         build_binary_op (LT_EXPR,
7092                                                          boolean_type_node,
7093                                                          lhs, tmp1)));
7094       break;
7095
7096     default:
7097       gcc_unreachable();
7098     }
7099
7100   gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
7101
7102   /* If we can fold the expression to a constant, just return it.
7103      The caller will deal with overflow, no need to generate a check.  */
7104   if (TREE_CONSTANT (gnu_expr))
7105     return gnu_expr;
7106
7107   check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
7108                        check_pos);
7109
7110   return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
7111 }
7112
7113 /* Emit code for a range check.  GNU_EXPR is the expression to be checked,
7114    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
7115    which we have to check.  GNAT_NODE is the GNAT node conveying the source
7116    location for which the error should be signaled.  */
7117
7118 static tree
7119 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
7120 {
7121   tree gnu_range_type = get_unpadded_type (gnat_range_type);
7122   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
7123   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
7124   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
7125
7126   /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
7127      This can for example happen when translating 'Val or 'Value.  */
7128   if (gnu_compare_type == gnu_range_type)
7129     return gnu_expr;
7130
7131   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
7132      we can't do anything since we might be truncating the bounds.  No
7133      check is needed in this case.  */
7134   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
7135       && (TYPE_PRECISION (gnu_compare_type)
7136           < TYPE_PRECISION (get_base_type (gnu_range_type))))
7137     return gnu_expr;
7138
7139   /* Checked expressions must be evaluated only once.  */
7140   gnu_expr = gnat_protect_expr (gnu_expr);
7141
7142   /* Note that the form of the check is
7143         (not (expr >= lo)) or (not (expr <= hi))
7144      the reason for this slightly convoluted form is that NaNs
7145      are not considered to be in range in the float case.  */
7146   return emit_check
7147     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7148                       invert_truthvalue
7149                       (build_binary_op (GE_EXPR, boolean_type_node,
7150                                        convert (gnu_compare_type, gnu_expr),
7151                                        convert (gnu_compare_type, gnu_low))),
7152                       invert_truthvalue
7153                       (build_binary_op (LE_EXPR, boolean_type_node,
7154                                         convert (gnu_compare_type, gnu_expr),
7155                                         convert (gnu_compare_type,
7156                                                  gnu_high)))),
7157      gnu_expr, CE_Range_Check_Failed, gnat_node);
7158 }
7159 \f
7160 /* Emit code for an index check.  GNU_ARRAY_OBJECT is the array object which
7161    we are about to index, GNU_EXPR is the index expression to be checked,
7162    GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
7163    has to be checked.  Note that for index checking we cannot simply use the
7164    emit_range_check function (although very similar code needs to be generated
7165    in both cases) since for index checking the array type against which we are
7166    checking the indices may be unconstrained and consequently we need to get
7167    the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
7168    The place where we need to do that is in subprograms having unconstrained
7169    array formal parameters.  GNAT_NODE is the GNAT node conveying the source
7170    location for which the error should be signaled.  */
7171
7172 static tree
7173 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
7174                   tree gnu_high, Node_Id gnat_node)
7175 {
7176   tree gnu_expr_check;
7177
7178   /* Checked expressions must be evaluated only once.  */
7179   gnu_expr = gnat_protect_expr (gnu_expr);
7180
7181   /* Must do this computation in the base type in case the expression's
7182      type is an unsigned subtypes.  */
7183   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
7184
7185   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
7186      the object we are handling.  */
7187   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
7188   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
7189
7190   return emit_check
7191     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7192                       build_binary_op (LT_EXPR, boolean_type_node,
7193                                        gnu_expr_check,
7194                                        convert (TREE_TYPE (gnu_expr_check),
7195                                                 gnu_low)),
7196                       build_binary_op (GT_EXPR, boolean_type_node,
7197                                        gnu_expr_check,
7198                                        convert (TREE_TYPE (gnu_expr_check),
7199                                                 gnu_high))),
7200      gnu_expr, CE_Index_Check_Failed, gnat_node);
7201 }
7202 \f
7203 /* GNU_COND contains the condition corresponding to an access, discriminant or
7204    range check of value GNU_EXPR.  Build a COND_EXPR that returns GNU_EXPR if
7205    GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
7206    REASON is the code that says why the exception was raised.  GNAT_NODE is
7207    the GNAT node conveying the source location for which the error should be
7208    signaled.  */
7209
7210 static tree
7211 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
7212 {
7213   tree gnu_call
7214     = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
7215   tree gnu_result
7216     = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
7217                    build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
7218                            convert (TREE_TYPE (gnu_expr), integer_zero_node)),
7219                    gnu_expr);
7220
7221   /* GNU_RESULT has side effects if and only if GNU_EXPR has:
7222      we don't need to evaluate it just for the check.  */
7223   TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
7224
7225   return gnu_result;
7226 }
7227 \f
7228 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
7229    checks if OVERFLOW_P is true and range checks if RANGE_P is true.
7230    GNAT_TYPE is known to be an integral type.  If TRUNCATE_P true, do a
7231    float to integer conversion with truncation; otherwise round.
7232    GNAT_NODE is the GNAT node conveying the source location for which the
7233    error should be signaled.  */
7234
7235 static tree
7236 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
7237                     bool rangep, bool truncatep, Node_Id gnat_node)
7238 {
7239   tree gnu_type = get_unpadded_type (gnat_type);
7240   tree gnu_in_type = TREE_TYPE (gnu_expr);
7241   tree gnu_in_basetype = get_base_type (gnu_in_type);
7242   tree gnu_base_type = get_base_type (gnu_type);
7243   tree gnu_result = gnu_expr;
7244
7245   /* If we are not doing any checks, the output is an integral type, and
7246      the input is not a floating type, just do the conversion.  This
7247      shortcut is required to avoid problems with packed array types
7248      and simplifies code in all cases anyway.   */
7249   if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
7250       && !FLOAT_TYPE_P (gnu_in_type))
7251     return convert (gnu_type, gnu_expr);
7252
7253   /* First convert the expression to its base type.  This
7254      will never generate code, but makes the tests below much simpler.
7255      But don't do this if converting from an integer type to an unconstrained
7256      array type since then we need to get the bounds from the original
7257      (unpacked) type.  */
7258   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
7259     gnu_result = convert (gnu_in_basetype, gnu_result);
7260
7261   /* If overflow checks are requested,  we need to be sure the result will
7262      fit in the output base type.  But don't do this if the input
7263      is integer and the output floating-point.  */
7264   if (overflowp
7265       && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
7266     {
7267       /* Ensure GNU_EXPR only gets evaluated once.  */
7268       tree gnu_input = gnat_protect_expr (gnu_result);
7269       tree gnu_cond = boolean_false_node;
7270       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
7271       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
7272       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
7273       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
7274
7275       /* Convert the lower bounds to signed types, so we're sure we're
7276          comparing them properly.  Likewise, convert the upper bounds
7277          to unsigned types.  */
7278       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
7279         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
7280
7281       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7282           && !TYPE_UNSIGNED (gnu_in_basetype))
7283         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
7284
7285       if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
7286         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
7287
7288       if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
7289         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
7290
7291       /* Check each bound separately and only if the result bound
7292          is tighter than the bound on the input type.  Note that all the
7293          types are base types, so the bounds must be constant. Also,
7294          the comparison is done in the base type of the input, which
7295          always has the proper signedness.  First check for input
7296          integer (which means output integer), output float (which means
7297          both float), or mixed, in which case we always compare.
7298          Note that we have to do the comparison which would *fail* in the
7299          case of an error since if it's an FP comparison and one of the
7300          values is a NaN or Inf, the comparison will fail.  */
7301       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7302           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
7303           : (FLOAT_TYPE_P (gnu_base_type)
7304              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
7305                                  TREE_REAL_CST (gnu_out_lb))
7306              : 1))
7307         gnu_cond
7308           = invert_truthvalue
7309             (build_binary_op (GE_EXPR, boolean_type_node,
7310                               gnu_input, convert (gnu_in_basetype,
7311                                                   gnu_out_lb)));
7312
7313       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7314           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
7315           : (FLOAT_TYPE_P (gnu_base_type)
7316              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
7317                                  TREE_REAL_CST (gnu_in_lb))
7318              : 1))
7319         gnu_cond
7320           = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
7321                              invert_truthvalue
7322                              (build_binary_op (LE_EXPR, boolean_type_node,
7323                                                gnu_input,
7324                                                convert (gnu_in_basetype,
7325                                                         gnu_out_ub))));
7326
7327       if (!integer_zerop (gnu_cond))
7328         gnu_result = emit_check (gnu_cond, gnu_input,
7329                                  CE_Overflow_Check_Failed, gnat_node);
7330     }
7331
7332   /* Now convert to the result base type.  If this is a non-truncating
7333      float-to-integer conversion, round.  */
7334   if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
7335       && !truncatep)
7336     {
7337       REAL_VALUE_TYPE half_minus_pred_half, pred_half;
7338       tree gnu_conv, gnu_zero, gnu_comp, calc_type;
7339       tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
7340       const struct real_format *fmt;
7341
7342       /* The following calculations depend on proper rounding to even
7343          of each arithmetic operation. In order to prevent excess
7344          precision from spoiling this property, use the widest hardware
7345          floating-point type if FP_ARITH_MAY_WIDEN is true.  */
7346       calc_type
7347         = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
7348
7349       /* FIXME: Should not have padding in the first place.  */
7350       if (TYPE_IS_PADDING_P (calc_type))
7351         calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
7352
7353       /* Compute the exact value calc_type'Pred (0.5) at compile time.  */
7354       fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
7355       real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
7356       REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
7357                        half_minus_pred_half);
7358       gnu_pred_half = build_real (calc_type, pred_half);
7359
7360       /* If the input is strictly negative, subtract this value
7361          and otherwise add it from the input.  For 0.5, the result
7362          is exactly between 1.0 and the machine number preceding 1.0
7363          (for calc_type).  Since the last bit of 1.0 is even, this 0.5
7364          will round to 1.0, while all other number with an absolute
7365          value less than 0.5 round to 0.0.  For larger numbers exactly
7366          halfway between integers, rounding will always be correct as
7367          the true mathematical result will be closer to the higher
7368          integer compared to the lower one.  So, this constant works
7369          for all floating-point numbers.
7370
7371          The reason to use the same constant with subtract/add instead
7372          of a positive and negative constant is to allow the comparison
7373          to be scheduled in parallel with retrieval of the constant and
7374          conversion of the input to the calc_type (if necessary).  */
7375
7376       gnu_zero = convert (gnu_in_basetype, integer_zero_node);
7377       gnu_result = gnat_protect_expr (gnu_result);
7378       gnu_conv = convert (calc_type, gnu_result);
7379       gnu_comp
7380         = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
7381       gnu_add_pred_half
7382         = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
7383       gnu_subtract_pred_half
7384         = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
7385       gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
7386                                 gnu_add_pred_half, gnu_subtract_pred_half);
7387     }
7388
7389   if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
7390       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
7391       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
7392     gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
7393   else
7394     gnu_result = convert (gnu_base_type, gnu_result);
7395
7396   /* Finally, do the range check if requested.  Note that if the result type
7397      is a modular type, the range check is actually an overflow check.  */
7398   if (rangep
7399       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
7400           && TYPE_MODULAR_P (gnu_base_type) && overflowp))
7401     gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
7402
7403   return convert (gnu_type, gnu_result);
7404 }
7405 \f
7406 /* Return true if GNU_EXPR can be directly addressed.  This is the case
7407    unless it is an expression involving computation or if it involves a
7408    reference to a bitfield or to an object not sufficiently aligned for
7409    its type.  If GNU_TYPE is non-null, return true only if GNU_EXPR can
7410    be directly addressed as an object of this type.
7411
7412    *** Notes on addressability issues in the Ada compiler ***
7413
7414    This predicate is necessary in order to bridge the gap between Gigi
7415    and the middle-end about addressability of GENERIC trees.  A tree
7416    is said to be addressable if it can be directly addressed, i.e. if
7417    its address can be taken, is a multiple of the type's alignment on
7418    strict-alignment architectures and returns the first storage unit
7419    assigned to the object represented by the tree.
7420
7421    In the C family of languages, everything is in practice addressable
7422    at the language level, except for bit-fields.  This means that these
7423    compilers will take the address of any tree that doesn't represent
7424    a bit-field reference and expect the result to be the first storage
7425    unit assigned to the object.  Even in cases where this will result
7426    in unaligned accesses at run time, nothing is supposed to be done
7427    and the program is considered as erroneous instead (see PR c/18287).
7428
7429    The implicit assumptions made in the middle-end are in keeping with
7430    the C viewpoint described above:
7431      - the address of a bit-field reference is supposed to be never
7432        taken; the compiler (generally) will stop on such a construct,
7433      - any other tree is addressable if it is formally addressable,
7434        i.e. if it is formally allowed to be the operand of ADDR_EXPR.
7435
7436    In Ada, the viewpoint is the opposite one: nothing is addressable
7437    at the language level unless explicitly declared so.  This means
7438    that the compiler will both make sure that the trees representing
7439    references to addressable ("aliased" in Ada parlance) objects are
7440    addressable and make no real attempts at ensuring that the trees
7441    representing references to non-addressable objects are addressable.
7442
7443    In the first case, Ada is effectively equivalent to C and handing
7444    down the direct result of applying ADDR_EXPR to these trees to the
7445    middle-end works flawlessly.  In the second case, Ada cannot afford
7446    to consider the program as erroneous if the address of trees that
7447    are not addressable is requested for technical reasons, unlike C;
7448    as a consequence, the Ada compiler must arrange for either making
7449    sure that this address is not requested in the middle-end or for
7450    compensating by inserting temporaries if it is requested in Gigi.
7451
7452    The first goal can be achieved because the middle-end should not
7453    request the address of non-addressable trees on its own; the only
7454    exception is for the invocation of low-level block operations like
7455    memcpy, for which the addressability requirements are lower since
7456    the type's alignment can be disregarded.  In practice, this means
7457    that Gigi must make sure that such operations cannot be applied to
7458    non-BLKmode bit-fields.
7459
7460    The second goal is achieved by means of the addressable_p predicate,
7461    which computes whether a temporary must be inserted by Gigi when the
7462    address of a tree is requested; if so, the address of the temporary
7463    will be used in lieu of that of the original tree and some glue code
7464    generated to connect everything together.  */
7465
7466 static bool
7467 addressable_p (tree gnu_expr, tree gnu_type)
7468 {
7469   /* For an integral type, the size of the actual type of the object may not
7470      be greater than that of the expected type, otherwise an indirect access
7471      in the latter type wouldn't correctly set all the bits of the object.  */
7472   if (gnu_type
7473       && INTEGRAL_TYPE_P (gnu_type)
7474       && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
7475     return false;
7476
7477   /* The size of the actual type of the object may not be smaller than that
7478      of the expected type, otherwise an indirect access in the latter type
7479      would be larger than the object.  But only record types need to be
7480      considered in practice for this case.  */
7481   if (gnu_type
7482       && TREE_CODE (gnu_type) == RECORD_TYPE
7483       && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
7484     return false;
7485
7486   switch (TREE_CODE (gnu_expr))
7487     {
7488     case VAR_DECL:
7489     case PARM_DECL:
7490     case FUNCTION_DECL:
7491     case RESULT_DECL:
7492       /* All DECLs are addressable: if they are in a register, we can force
7493          them to memory.  */
7494       return true;
7495
7496     case UNCONSTRAINED_ARRAY_REF:
7497     case INDIRECT_REF:
7498       /* Taking the address of a dereference yields the original pointer.  */
7499       return true;
7500
7501     case STRING_CST:
7502     case INTEGER_CST:
7503       /* Taking the address yields a pointer to the constant pool.  */
7504       return true;
7505
7506     case CONSTRUCTOR:
7507       /* Taking the address of a static constructor yields a pointer to the
7508          tree constant pool.  */
7509       return TREE_STATIC (gnu_expr) ? true : false;
7510
7511     case NULL_EXPR:
7512     case SAVE_EXPR:
7513     case CALL_EXPR:
7514     case PLUS_EXPR:
7515     case MINUS_EXPR:
7516     case BIT_IOR_EXPR:
7517     case BIT_XOR_EXPR:
7518     case BIT_AND_EXPR:
7519     case BIT_NOT_EXPR:
7520       /* All rvalues are deemed addressable since taking their address will
7521          force a temporary to be created by the middle-end.  */
7522       return true;
7523
7524     case COMPOUND_EXPR:
7525       /* The address of a compound expression is that of its 2nd operand.  */
7526       return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
7527
7528     case COND_EXPR:
7529       /* We accept &COND_EXPR as soon as both operands are addressable and
7530          expect the outcome to be the address of the selected operand.  */
7531       return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
7532               && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
7533
7534     case COMPONENT_REF:
7535       return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
7536                 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
7537                    the field is sufficiently aligned, in case it is subject
7538                    to a pragma Component_Alignment.  But we don't need to
7539                    check the alignment of the containing record, as it is
7540                    guaranteed to be not smaller than that of its most
7541                    aligned field that is not a bit-field.  */
7542                 && (!STRICT_ALIGNMENT
7543                     || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
7544                        >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
7545                /* The field of a padding record is always addressable.  */
7546                || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
7547               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7548
7549     case ARRAY_REF:  case ARRAY_RANGE_REF:
7550     case REALPART_EXPR:  case IMAGPART_EXPR:
7551     case NOP_EXPR:
7552       return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
7553
7554     case CONVERT_EXPR:
7555       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
7556               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7557
7558     case VIEW_CONVERT_EXPR:
7559       {
7560         /* This is addressable if we can avoid a copy.  */
7561         tree type = TREE_TYPE (gnu_expr);
7562         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
7563         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
7564                   && (!STRICT_ALIGNMENT
7565                       || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7566                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
7567                  || ((TYPE_MODE (type) == BLKmode
7568                       || TYPE_MODE (inner_type) == BLKmode)
7569                      && (!STRICT_ALIGNMENT
7570                          || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7571                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
7572                          || TYPE_ALIGN_OK (type)
7573                          || TYPE_ALIGN_OK (inner_type))))
7574                 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7575       }
7576
7577     default:
7578       return false;
7579     }
7580 }
7581 \f
7582 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
7583    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
7584    make a GCC type for GNAT_ENTITY and set up the correspondence.  */
7585
7586 void
7587 process_type (Entity_Id gnat_entity)
7588 {
7589   tree gnu_old
7590     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
7591   tree gnu_new;
7592
7593   /* If we are to delay elaboration of this type, just do any
7594      elaborations needed for expressions within the declaration and
7595      make a dummy type entry for this node and its Full_View (if
7596      any) in case something points to it.  Don't do this if it
7597      has already been done (the only way that can happen is if
7598      the private completion is also delayed).  */
7599   if (Present (Freeze_Node (gnat_entity))
7600       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7601           && Present (Full_View (gnat_entity))
7602           && Freeze_Node (Full_View (gnat_entity))
7603           && !present_gnu_tree (Full_View (gnat_entity))))
7604     {
7605       elaborate_entity (gnat_entity);
7606
7607       if (!gnu_old)
7608         {
7609           tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
7610           save_gnu_tree (gnat_entity, gnu_decl, false);
7611           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7612               && Present (Full_View (gnat_entity)))
7613             {
7614               if (Has_Completion_In_Body (gnat_entity))
7615                 DECL_TAFT_TYPE_P (gnu_decl) = 1;
7616               save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
7617             }
7618         }
7619
7620       return;
7621     }
7622
7623   /* If we saved away a dummy type for this node it means that this
7624      made the type that corresponds to the full type of an incomplete
7625      type.  Clear that type for now and then update the type in the
7626      pointers.  */
7627   if (gnu_old)
7628     {
7629       gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
7630                   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
7631
7632       save_gnu_tree (gnat_entity, NULL_TREE, false);
7633     }
7634
7635   /* Now fully elaborate the type.  */
7636   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
7637   gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
7638
7639   /* If we have an old type and we've made pointers to this type, update those
7640      pointers.  If this is a Taft amendment type in the main unit, we need to
7641      mark the type as used since other units referencing it don't see the full
7642      declaration and, therefore, cannot mark it as used themselves.  */
7643   if (gnu_old)
7644     {
7645       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
7646                          TREE_TYPE (gnu_new));
7647       if (DECL_TAFT_TYPE_P (gnu_old))
7648         used_types_insert (TREE_TYPE (gnu_new));
7649     }
7650
7651   /* If this is a record type corresponding to a task or protected type
7652      that is a completion of an incomplete type, perform a similar update
7653      on the type.  ??? Including protected types here is a guess.  */
7654   if (IN (Ekind (gnat_entity), Record_Kind)
7655       && Is_Concurrent_Record_Type (gnat_entity)
7656       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
7657     {
7658       tree gnu_task_old
7659         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
7660
7661       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7662                      NULL_TREE, false);
7663       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7664                      gnu_new, false);
7665
7666       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
7667                          TREE_TYPE (gnu_new));
7668     }
7669 }
7670 \f
7671 /* GNAT_ENTITY is the type of the resulting constructors,
7672    GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
7673    and GNU_TYPE is the GCC type of the corresponding record.
7674
7675    Return a CONSTRUCTOR to build the record.  */
7676
7677 static tree
7678 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
7679 {
7680   tree gnu_list, gnu_result;
7681
7682   /* We test for GNU_FIELD being empty in the case where a variant
7683      was the last thing since we don't take things off GNAT_ASSOC in
7684      that case.  We check GNAT_ASSOC in case we have a variant, but it
7685      has no fields.  */
7686
7687   for (gnu_list = NULL_TREE; Present (gnat_assoc);
7688        gnat_assoc = Next (gnat_assoc))
7689     {
7690       Node_Id gnat_field = First (Choices (gnat_assoc));
7691       tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
7692       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
7693
7694       /* The expander is supposed to put a single component selector name
7695          in every record component association.  */
7696       gcc_assert (No (Next (gnat_field)));
7697
7698       /* Ignore fields that have Corresponding_Discriminants since we'll
7699          be setting that field in the parent.  */
7700       if (Present (Corresponding_Discriminant (Entity (gnat_field)))
7701           && Is_Tagged_Type (Scope (Entity (gnat_field))))
7702         continue;
7703
7704       /* Also ignore discriminants of Unchecked_Unions.  */
7705       else if (Is_Unchecked_Union (gnat_entity)
7706                && Ekind (Entity (gnat_field)) == E_Discriminant)
7707         continue;
7708
7709       /* Before assigning a value in an aggregate make sure range checks
7710          are done if required.  Then convert to the type of the field.  */
7711       if (Do_Range_Check (Expression (gnat_assoc)))
7712         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
7713
7714       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
7715
7716       /* Add the field and expression to the list.  */
7717       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
7718     }
7719
7720   gnu_result = extract_values (gnu_list, gnu_type);
7721
7722 #ifdef ENABLE_CHECKING
7723   {
7724     tree gnu_field;
7725
7726     /* Verify every entry in GNU_LIST was used.  */
7727     for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
7728       gcc_assert (TREE_ADDRESSABLE (gnu_field));
7729   }
7730 #endif
7731
7732   return gnu_result;
7733 }
7734
7735 /* Build a possibly nested constructor for array aggregates.  GNAT_EXPR is
7736    the first element of an array aggregate.  It may itself be an aggregate.
7737    GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
7738    GNAT_COMPONENT_TYPE is the type of the array component; it is needed
7739    for range checking.  */
7740
7741 static tree
7742 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
7743                     Entity_Id gnat_component_type)
7744 {
7745   tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
7746   tree gnu_expr;
7747   VEC(constructor_elt,gc) *gnu_expr_vec = NULL;
7748
7749   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
7750     {
7751       /* If the expression is itself an array aggregate then first build the
7752          innermost constructor if it is part of our array (multi-dimensional
7753          case).  */
7754       if (Nkind (gnat_expr) == N_Aggregate
7755           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
7756           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
7757         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
7758                                        TREE_TYPE (gnu_array_type),
7759                                        gnat_component_type);
7760       else
7761         {
7762           gnu_expr = gnat_to_gnu (gnat_expr);
7763
7764           /* Before assigning the element to the array, make sure it is
7765              in range.  */
7766           if (Do_Range_Check (gnat_expr))
7767             gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
7768         }
7769
7770       CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
7771                               convert (TREE_TYPE (gnu_array_type), gnu_expr));
7772
7773       gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node);
7774     }
7775
7776   return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
7777 }
7778 \f
7779 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
7780    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
7781    of the associations that are from RECORD_TYPE.  If we see an internal
7782    record, make a recursive call to fill it in as well.  */
7783
7784 static tree
7785 extract_values (tree values, tree record_type)
7786 {
7787   tree field, tem;
7788   VEC(constructor_elt,gc) *v = NULL;
7789
7790   for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
7791     {
7792       tree value = 0;
7793
7794       /* _Parent is an internal field, but may have values in the aggregate,
7795          so check for values first.  */
7796       if ((tem = purpose_member (field, values)))
7797         {
7798           value = TREE_VALUE (tem);
7799           TREE_ADDRESSABLE (tem) = 1;
7800         }
7801
7802       else if (DECL_INTERNAL_P (field))
7803         {
7804           value = extract_values (values, TREE_TYPE (field));
7805           if (TREE_CODE (value) == CONSTRUCTOR
7806               && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
7807             value = 0;
7808         }
7809       else
7810         /* If we have a record subtype, the names will match, but not the
7811            actual FIELD_DECLs.  */
7812         for (tem = values; tem; tem = TREE_CHAIN (tem))
7813           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
7814             {
7815               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
7816               TREE_ADDRESSABLE (tem) = 1;
7817             }
7818
7819       if (!value)
7820         continue;
7821
7822       CONSTRUCTOR_APPEND_ELT (v, field, value);
7823     }
7824
7825   return gnat_build_constructor (record_type, v);
7826 }
7827 \f
7828 /* EXP is to be treated as an array or record.  Handle the cases when it is
7829    an access object and perform the required dereferences.  */
7830
7831 static tree
7832 maybe_implicit_deref (tree exp)
7833 {
7834   /* If the type is a pointer, dereference it.  */
7835   if (POINTER_TYPE_P (TREE_TYPE (exp))
7836       || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
7837     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
7838
7839   /* If we got a padded type, remove it too.  */
7840   if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
7841     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
7842
7843   return exp;
7844 }
7845 \f
7846 /* Convert SLOC into LOCUS.  Return true if SLOC corresponds to a source code
7847    location and false if it doesn't.  In the former case, set the Gigi global
7848    variable REF_FILENAME to the simple debug file name as given by sinput.  */
7849
7850 bool
7851 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
7852 {
7853   if (Sloc == No_Location)
7854     return false;
7855
7856   if (Sloc <= Standard_Location)
7857     {
7858       *locus = BUILTINS_LOCATION;
7859       return false;
7860     }
7861   else
7862     {
7863       Source_File_Index file = Get_Source_File_Index (Sloc);
7864       Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
7865       Column_Number column = Get_Column_Number (Sloc);
7866       struct line_map *map = &line_table->maps[file - 1];
7867
7868       /* Translate the location according to the line-map.h formula.  */
7869       *locus = map->start_location
7870                 + ((line - map->to_line) << map->column_bits)
7871                 + (column & ((1 << map->column_bits) - 1));
7872     }
7873
7874   ref_filename
7875     = IDENTIFIER_POINTER
7876       (get_identifier
7877        (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
7878
7879   return true;
7880 }
7881
7882 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
7883    don't do anything if it doesn't correspond to a source location.  */
7884
7885 static void
7886 set_expr_location_from_node (tree node, Node_Id gnat_node)
7887 {
7888   location_t locus;
7889
7890   if (!Sloc_to_locus (Sloc (gnat_node), &locus))
7891     return;
7892
7893   SET_EXPR_LOCATION (node, locus);
7894 }
7895
7896 /* More elaborate version of set_expr_location_from_node to be used in more
7897    general contexts, for example the result of the translation of a generic
7898    GNAT node.  */
7899
7900 static void
7901 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
7902 {
7903   /* Set the location information on the node if it is a real expression.
7904      References can be reused for multiple GNAT nodes and they would get
7905      the location information of their last use.  Also make sure not to
7906      overwrite an existing location as it is probably more precise.  */
7907
7908   switch (TREE_CODE (node))
7909     {
7910     CASE_CONVERT:
7911     case NON_LVALUE_EXPR:
7912       break;
7913
7914     case COMPOUND_EXPR:
7915       if (EXPR_P (TREE_OPERAND (node, 1)))
7916         set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
7917
7918       /* ... fall through ... */
7919
7920     default:
7921       if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
7922         {
7923           set_expr_location_from_node (node, gnat_node);
7924           set_end_locus_from_node (node, gnat_node);
7925         }
7926       break;
7927     }
7928 }
7929 \f
7930 /* Return a colon-separated list of encodings contained in encoded Ada
7931    name.  */
7932
7933 static const char *
7934 extract_encoding (const char *name)
7935 {
7936   char *encoding = (char *) ggc_alloc_atomic (strlen (name));
7937   get_encoding (name, encoding);
7938   return encoding;
7939 }
7940
7941 /* Extract the Ada name from an encoded name.  */
7942
7943 static const char *
7944 decode_name (const char *name)
7945 {
7946   char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
7947   __gnat_decode (name, decoded, 0);
7948   return decoded;
7949 }
7950 \f
7951 /* Post an error message.  MSG is the error message, properly annotated.
7952    NODE is the node at which to post the error and the node to use for the
7953    '&' substitution.  */
7954
7955 void
7956 post_error (const char *msg, Node_Id node)
7957 {
7958   String_Template temp;
7959   Fat_Pointer fp;
7960
7961   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7962   fp.Array = msg, fp.Bounds = &temp;
7963   if (Present (node))
7964     Error_Msg_N (fp, node);
7965 }
7966
7967 /* Similar to post_error, but NODE is the node at which to post the error and
7968    ENT is the node to use for the '&' substitution.  */
7969
7970 void
7971 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
7972 {
7973   String_Template temp;
7974   Fat_Pointer fp;
7975
7976   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7977   fp.Array = msg, fp.Bounds = &temp;
7978   if (Present (node))
7979     Error_Msg_NE (fp, node, ent);
7980 }
7981
7982 /* Similar to post_error_ne, but NUM is the number to use for the '^'.  */
7983
7984 void
7985 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
7986 {
7987   Error_Msg_Uint_1 = UI_From_Int (num);
7988   post_error_ne (msg, node, ent);
7989 }
7990
7991 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
7992    location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
7993    most sense.  Return true if a sensible assignment was performed.  */
7994
7995 static bool
7996 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
7997 {
7998   Node_Id gnat_end_label = Empty;
7999   location_t end_locus;
8000
8001   /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
8002      end_locus when there is one.  We consider only GNAT nodes with a possible
8003      End_Label attached.  If the End_Label actually was unassigned, fallback
8004      on the orginal node.  We'd better assign an explicit sloc associated with
8005      the outer construct in any case.  */
8006
8007   switch (Nkind (gnat_node))
8008     {
8009     case N_Package_Body:
8010     case N_Subprogram_Body:
8011     case N_Block_Statement:
8012       gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
8013       break;
8014
8015     case N_Package_Declaration:
8016       gnat_end_label = End_Label (Specification (gnat_node));
8017       break;
8018
8019     default:
8020       return false;
8021     }
8022
8023   gnat_node = Present (gnat_end_label) ? gnat_end_label : gnat_node;
8024
8025   /* Some expanded subprograms have neither an End_Label nor a Sloc
8026      attached.  Notify that to callers.  */
8027
8028   if (!Sloc_to_locus (Sloc (gnat_node), &end_locus))
8029     return false;
8030
8031   switch (TREE_CODE (gnu_node))
8032     {
8033     case BIND_EXPR:
8034       BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
8035       return true;
8036
8037     case FUNCTION_DECL:
8038       DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
8039       return true;
8040
8041     default:
8042       return false;
8043     }
8044 }
8045 \f
8046 /* Similar to post_error_ne, but T is a GCC tree representing the number to
8047    write.  If T represents a constant, the text inside curly brackets in
8048    MSG will be output (presumably including a '^').  Otherwise it will not
8049    be output and the text inside square brackets will be output instead.  */
8050
8051 void
8052 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
8053 {
8054   char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
8055   char start_yes, end_yes, start_no, end_no;
8056   const char *p;
8057   char *q;
8058
8059   if (TREE_CODE (t) == INTEGER_CST)
8060     {
8061       Error_Msg_Uint_1 = UI_From_gnu (t);
8062       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
8063     }
8064   else
8065     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
8066
8067   for (p = msg, q = new_msg; *p; p++)
8068     {
8069       if (*p == start_yes)
8070         for (p++; *p != end_yes; p++)
8071           *q++ = *p;
8072       else if (*p == start_no)
8073         for (p++; *p != end_no; p++)
8074           ;
8075       else
8076         *q++ = *p;
8077     }
8078
8079   *q = 0;
8080
8081   post_error_ne (new_msg, node, ent);
8082 }
8083
8084 /* Similar to post_error_ne_tree, but NUM is a second integer to write.  */
8085
8086 void
8087 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
8088                       int num)
8089 {
8090   Error_Msg_Uint_2 = UI_From_Int (num);
8091   post_error_ne_tree (msg, node, ent, t);
8092 }
8093 \f
8094 /* Initialize the table that maps GNAT codes to GCC codes for simple
8095    binary and unary operations.  */
8096
8097 static void
8098 init_code_table (void)
8099 {
8100   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
8101   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
8102
8103   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
8104   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
8105   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
8106   gnu_codes[N_Op_Eq] = EQ_EXPR;
8107   gnu_codes[N_Op_Ne] = NE_EXPR;
8108   gnu_codes[N_Op_Lt] = LT_EXPR;
8109   gnu_codes[N_Op_Le] = LE_EXPR;
8110   gnu_codes[N_Op_Gt] = GT_EXPR;
8111   gnu_codes[N_Op_Ge] = GE_EXPR;
8112   gnu_codes[N_Op_Add] = PLUS_EXPR;
8113   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
8114   gnu_codes[N_Op_Multiply] = MULT_EXPR;
8115   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
8116   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
8117   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
8118   gnu_codes[N_Op_Abs] = ABS_EXPR;
8119   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
8120   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
8121   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
8122   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
8123   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
8124   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
8125 }
8126
8127 /* Return a label to branch to for the exception type in KIND or NULL_TREE
8128    if none.  */
8129
8130 tree
8131 get_exception_label (char kind)
8132 {
8133   if (kind == N_Raise_Constraint_Error)
8134     return VEC_last (tree, gnu_constraint_error_label_stack);
8135   else if (kind == N_Raise_Storage_Error)
8136     return VEC_last (tree, gnu_storage_error_label_stack);
8137   else if (kind == N_Raise_Program_Error)
8138     return VEC_last (tree, gnu_program_error_label_stack);
8139   else
8140     return NULL_TREE;
8141 }
8142
8143 /* Return the decl for the current elaboration procedure.  */
8144
8145 tree
8146 get_elaboration_procedure (void)
8147 {
8148   return VEC_last (tree, gnu_elab_proc_stack);
8149 }
8150
8151 #include "gt-ada-trans.h"