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