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;