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