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 other address attributes applied to a nested function,
1399          find an inner ADDR_EXPR and annotate it so that we can issue
1400          a useful warning with -Wtrampolines.  */
1401       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1402         {
1403           gnu_expr = remove_conversions (gnu_result, false);
1404
1405           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1406               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1407             {
1408               set_expr_location_from_node (gnu_expr, gnat_node);
1409
1410               /* Check that we're not violating the No_Implicit_Dynamic_Code
1411                  restriction.  Be conservative if we don't know anything
1412                  about the trampoline strategy for the target.  */
1413               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1414             }
1415         }
1416       break;
1417
1418     case Attr_Pool_Address:
1419       {
1420         tree gnu_obj_type;
1421         tree gnu_ptr = gnu_prefix;
1422
1423         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1424
1425         /* If this is an unconstrained array, we know the object has been
1426            allocated with the template in front of the object.  So compute
1427            the template address.  */
1428         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1429           gnu_ptr
1430             = convert (build_pointer_type
1431                        (TYPE_OBJECT_RECORD_TYPE
1432                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1433                        gnu_ptr);
1434
1435         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1436         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1437             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1438           {
1439             tree gnu_char_ptr_type
1440               = build_pointer_type (unsigned_char_type_node);
1441             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1442             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1443             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1444                                        gnu_ptr, gnu_pos);
1445           }
1446
1447         gnu_result = convert (gnu_result_type, gnu_ptr);
1448       }
1449       break;
1450
1451     case Attr_Size:
1452     case Attr_Object_Size:
1453     case Attr_Value_Size:
1454     case Attr_Max_Size_In_Storage_Elements:
1455       gnu_expr = gnu_prefix;
1456
1457       /* Remove NOPs and conversions between original and packable version
1458          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1459          to see if a COMPONENT_REF was involved.  */
1460       while (TREE_CODE (gnu_expr) == NOP_EXPR
1461              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1462                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1463                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1464                     == RECORD_TYPE
1465                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1466                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1467         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1468
1469       gnu_prefix = remove_conversions (gnu_prefix, true);
1470       prefix_unused = true;
1471       gnu_type = TREE_TYPE (gnu_prefix);
1472
1473       /* Replace an unconstrained array type with the type of the underlying
1474          array.  We can't do this with a call to maybe_unconstrained_array
1475          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1476          use the record type that will be used to allocate the object and its
1477          template.  */
1478       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1479         {
1480           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1481           if (attribute != Attr_Max_Size_In_Storage_Elements)
1482             gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1483         }
1484
1485       /* If we're looking for the size of a field, return the field size.
1486          Otherwise, if the prefix is an object, or if we're looking for
1487          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1488          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1489       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1490         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1491       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1492                || attribute == Attr_Object_Size
1493                || attribute == Attr_Max_Size_In_Storage_Elements)
1494         {
1495           /* If the prefix is an object of a padded type, the GCC size isn't
1496              relevant to the programmer.  Normally what we want is the RM size,
1497              which was set from the specified size, but if it was not set, we
1498              want the size of the field.  Using the MAX of those two produces
1499              the right result in all cases.  Don't use the size of the field
1500              if it's self-referential, since that's never what's wanted.  */
1501           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1502               && TYPE_IS_PADDING_P (gnu_type)
1503               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1504             {
1505               gnu_result = rm_size (gnu_type);
1506               if (!CONTAINS_PLACEHOLDER_P
1507                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1508                 gnu_result
1509                   = size_binop (MAX_EXPR, gnu_result,
1510                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1511             }
1512           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1513             {
1514               Node_Id gnat_deref = Prefix (gnat_node);
1515               Node_Id gnat_actual_subtype
1516                 = Actual_Designated_Subtype (gnat_deref);
1517               tree gnu_ptr_type
1518                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1519
1520               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1521                   && Present (gnat_actual_subtype))
1522                 {
1523                   tree gnu_actual_obj_type
1524                     = gnat_to_gnu_type (gnat_actual_subtype);
1525                   gnu_type
1526                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1527                                                       gnu_actual_obj_type,
1528                                                       get_identifier ("SIZE"),
1529                                                       false);
1530                 }
1531
1532               gnu_result = TYPE_SIZE (gnu_type);
1533             }
1534           else
1535             gnu_result = TYPE_SIZE (gnu_type);
1536         }
1537       else
1538         gnu_result = rm_size (gnu_type);
1539
1540       /* Deal with a self-referential size by returning the maximum size for
1541          a type and by qualifying the size with the object otherwise.  */
1542       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1543         {
1544           if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1545             gnu_result = max_size (gnu_result, true);
1546           else
1547             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1548         }
1549
1550       /* If the type contains a template, subtract its size.  */
1551       if (TREE_CODE (gnu_type) == RECORD_TYPE
1552           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1553         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1554                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1555
1556       /* For 'Max_Size_In_Storage_Elements, adjust the unit.  */
1557       if (attribute == Attr_Max_Size_In_Storage_Elements)
1558         gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1559
1560       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1561       break;
1562
1563     case Attr_Alignment:
1564       {
1565         unsigned int align;
1566
1567         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1568             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1569           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1570
1571         gnu_type = TREE_TYPE (gnu_prefix);
1572         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1573         prefix_unused = true;
1574
1575         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1576           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1577         else
1578           {
1579             Node_Id gnat_prefix = Prefix (gnat_node);
1580             Entity_Id gnat_type = Etype (gnat_prefix);
1581             unsigned int double_align;
1582             bool is_capped_double, align_clause;
1583
1584             /* If the default alignment of "double" or larger scalar types is
1585                specifically capped and there is an alignment clause neither
1586                on the type nor on the prefix itself, return the cap.  */
1587             if ((double_align = double_float_alignment) > 0)
1588               is_capped_double
1589                 = is_double_float_or_array (gnat_type, &align_clause);
1590             else if ((double_align = double_scalar_alignment) > 0)
1591               is_capped_double
1592                 = is_double_scalar_or_array (gnat_type, &align_clause);
1593             else
1594               is_capped_double = align_clause = false;
1595
1596             if (is_capped_double
1597                 && Nkind (gnat_prefix) == N_Identifier
1598                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1599               align_clause = true;
1600
1601             if (is_capped_double && !align_clause)
1602               align = double_align;
1603             else
1604               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1605           }
1606
1607         gnu_result = size_int (align);
1608       }
1609       break;
1610
1611     case Attr_First:
1612     case Attr_Last:
1613     case Attr_Range_Length:
1614       prefix_unused = true;
1615
1616       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1617         {
1618           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1619
1620           if (attribute == Attr_First)
1621             gnu_result = TYPE_MIN_VALUE (gnu_type);
1622           else if (attribute == Attr_Last)
1623             gnu_result = TYPE_MAX_VALUE (gnu_type);
1624           else
1625             gnu_result
1626               = build_binary_op
1627                 (MAX_EXPR, get_base_type (gnu_result_type),
1628                  build_binary_op
1629                  (PLUS_EXPR, get_base_type (gnu_result_type),
1630                   build_binary_op (MINUS_EXPR,
1631                                    get_base_type (gnu_result_type),
1632                                    convert (gnu_result_type,
1633                                             TYPE_MAX_VALUE (gnu_type)),
1634                                    convert (gnu_result_type,
1635                                             TYPE_MIN_VALUE (gnu_type))),
1636                   convert (gnu_result_type, integer_one_node)),
1637                  convert (gnu_result_type, integer_zero_node));
1638
1639           break;
1640         }
1641
1642       /* ... fall through ... */
1643
1644     case Attr_Length:
1645       {
1646         int Dimension = (Present (Expressions (gnat_node))
1647                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1648                          : 1), i;
1649         struct parm_attr_d *pa = NULL;
1650         Entity_Id gnat_param = Empty;
1651
1652         /* Make sure any implicit dereference gets done.  */
1653         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1654         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1655
1656         /* We treat unconstrained array In parameters specially.  */
1657         if (!Is_Constrained (Etype (Prefix (gnat_node))))
1658           {
1659             Node_Id gnat_prefix = Prefix (gnat_node);
1660
1661             /* This is the direct case.  */
1662             if (Nkind (gnat_prefix) == N_Identifier
1663                 && Ekind (Entity (gnat_prefix)) == E_In_Parameter)
1664               gnat_param = Entity (gnat_prefix);
1665
1666             /* This is the indirect case.  Note that we need to be sure that
1667                the access value cannot be null as we'll hoist the load.  */
1668             if (Nkind (gnat_prefix) == N_Explicit_Dereference
1669                 && Nkind (Prefix (gnat_prefix)) == N_Identifier
1670                 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter
1671                 && Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
1672               gnat_param = Entity (Prefix (gnat_prefix));
1673           }
1674
1675         gnu_type = TREE_TYPE (gnu_prefix);
1676         prefix_unused = true;
1677         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1678
1679         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1680           {
1681             int ndim;
1682             tree gnu_type_temp;
1683
1684             for (ndim = 1, gnu_type_temp = gnu_type;
1685                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1686                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1687                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1688               ;
1689
1690             Dimension = ndim + 1 - Dimension;
1691           }
1692
1693         for (i = 1; i < Dimension; i++)
1694           gnu_type = TREE_TYPE (gnu_type);
1695
1696         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1697
1698         /* When not optimizing, look up the slot associated with the parameter
1699            and the dimension in the cache and create a new one on failure.  */
1700         if (!optimize && Present (gnat_param))
1701           {
1702             FOR_EACH_VEC_ELT (parm_attr, f_parm_attr_cache, i, pa)
1703               if (pa->id == gnat_param && pa->dim == Dimension)
1704                 break;
1705
1706             if (!pa)
1707               {
1708                 pa = ggc_alloc_cleared_parm_attr_d ();
1709                 pa->id = gnat_param;
1710                 pa->dim = Dimension;
1711                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1712               }
1713           }
1714
1715         /* Return the cached expression or build a new one.  */
1716         if (attribute == Attr_First)
1717           {
1718             if (pa && pa->first)
1719               {
1720                 gnu_result = pa->first;
1721                 break;
1722               }
1723
1724             gnu_result
1725               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1726           }
1727
1728         else if (attribute == Attr_Last)
1729           {
1730             if (pa && pa->last)
1731               {
1732                 gnu_result = pa->last;
1733                 break;
1734               }
1735
1736             gnu_result
1737               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1738           }
1739
1740         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1741           {
1742             if (pa && pa->length)
1743               {
1744                 gnu_result = pa->length;
1745                 break;
1746               }
1747             else
1748               {
1749                 /* We used to compute the length as max (hb - lb + 1, 0),
1750                    which could overflow for some cases of empty arrays, e.g.
1751                    when lb == index_type'first.  We now compute the length as
1752                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1753                    much rarer cases, for extremely large arrays we expect
1754                    never to encounter in practice.  In addition, the former
1755                    computation required the use of potentially constraining
1756                    signed arithmetic while the latter doesn't.  Note that
1757                    the comparison must be done in the original index type,
1758                    to avoid any overflow during the conversion.  */
1759                 tree comp_type = get_base_type (gnu_result_type);
1760                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1761                 tree lb = TYPE_MIN_VALUE (index_type);
1762                 tree hb = TYPE_MAX_VALUE (index_type);
1763                 gnu_result
1764                   = build_binary_op (PLUS_EXPR, comp_type,
1765                                      build_binary_op (MINUS_EXPR,
1766                                                       comp_type,
1767                                                       convert (comp_type, hb),
1768                                                       convert (comp_type, lb)),
1769                                      convert (comp_type, integer_one_node));
1770                 gnu_result
1771                   = build_cond_expr (comp_type,
1772                                      build_binary_op (GE_EXPR,
1773                                                       boolean_type_node,
1774                                                       hb, lb),
1775                                      gnu_result,
1776                                      convert (comp_type, integer_zero_node));
1777               }
1778           }
1779
1780         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1781            handling.  Note that these attributes could not have been used on
1782            an unconstrained array type.  */
1783         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1784
1785         /* Cache the expression we have just computed.  Since we want to do it
1786            at run time, we force the use of a SAVE_EXPR and let the gimplifier
1787            create the temporary in the outermost binding level.  We will make
1788            sure in Subprogram_Body_to_gnu that it is evaluated on all possible
1789            paths by forcing its evaluation on entry of the function.  */
1790         if (pa)
1791           {
1792             gnu_result
1793               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1794             if (attribute == Attr_First)
1795               pa->first = gnu_result;
1796             else if (attribute == Attr_Last)
1797               pa->last = gnu_result;
1798             else
1799               pa->length = gnu_result;
1800           }
1801
1802         /* Set the source location onto the predicate of the condition in the
1803            'Length case but do not do it if the expression is cached to avoid
1804            messing up the debug info.  */
1805         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1806                  && TREE_CODE (gnu_result) == COND_EXPR
1807                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1808           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1809                                        gnat_node);
1810
1811         break;
1812       }
1813
1814     case Attr_Bit_Position:
1815     case Attr_Position:
1816     case Attr_First_Bit:
1817     case Attr_Last_Bit:
1818     case Attr_Bit:
1819       {
1820         HOST_WIDE_INT bitsize;
1821         HOST_WIDE_INT bitpos;
1822         tree gnu_offset;
1823         tree gnu_field_bitpos;
1824         tree gnu_field_offset;
1825         tree gnu_inner;
1826         enum machine_mode mode;
1827         int unsignedp, volatilep;
1828
1829         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1830         gnu_prefix = remove_conversions (gnu_prefix, true);
1831         prefix_unused = true;
1832
1833         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1834            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1835         if (attribute == Attr_Bit
1836             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1837             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1838           {
1839             gnu_result = integer_zero_node;
1840             break;
1841           }
1842
1843         else
1844           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1845                       || (attribute == Attr_Bit_Position
1846                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1847
1848         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1849                              &mode, &unsignedp, &volatilep, false);
1850
1851         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1852           {
1853             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1854             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1855
1856             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1857                  TREE_CODE (gnu_inner) == COMPONENT_REF
1858                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1859                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1860               {
1861                 gnu_field_bitpos
1862                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1863                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1864                 gnu_field_offset
1865                   = size_binop (PLUS_EXPR, gnu_field_offset,
1866                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1867               }
1868           }
1869         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1870           {
1871             gnu_field_bitpos = bit_position (gnu_prefix);
1872             gnu_field_offset = byte_position (gnu_prefix);
1873           }
1874         else
1875           {
1876             gnu_field_bitpos = bitsize_zero_node;
1877             gnu_field_offset = size_zero_node;
1878           }
1879
1880         switch (attribute)
1881           {
1882           case Attr_Position:
1883             gnu_result = gnu_field_offset;
1884             break;
1885
1886           case Attr_First_Bit:
1887           case Attr_Bit:
1888             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1889             break;
1890
1891           case Attr_Last_Bit:
1892             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1893             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1894                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1895             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1896                                      bitsize_one_node);
1897             break;
1898
1899           case Attr_Bit_Position:
1900             gnu_result = gnu_field_bitpos;
1901             break;
1902                 }
1903
1904         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1905            handling.  */
1906         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1907         break;
1908       }
1909
1910     case Attr_Min:
1911     case Attr_Max:
1912       {
1913         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1914         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1915
1916         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1917         gnu_result = build_binary_op (attribute == Attr_Min
1918                                       ? MIN_EXPR : MAX_EXPR,
1919                                       gnu_result_type, gnu_lhs, gnu_rhs);
1920       }
1921       break;
1922
1923     case Attr_Passed_By_Reference:
1924       gnu_result = size_int (default_pass_by_ref (gnu_type)
1925                              || must_pass_by_ref (gnu_type));
1926       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1927       break;
1928
1929     case Attr_Component_Size:
1930       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1931           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1932         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1933
1934       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1935       gnu_type = TREE_TYPE (gnu_prefix);
1936
1937       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1938         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1939
1940       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1941              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1942         gnu_type = TREE_TYPE (gnu_type);
1943
1944       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1945
1946       /* Note this size cannot be self-referential.  */
1947       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1948       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1949       prefix_unused = true;
1950       break;
1951
1952     case Attr_Descriptor_Size:
1953       gnu_type = TREE_TYPE (gnu_prefix);
1954       gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
1955
1956       /* What we want is the offset of the ARRAY field in the record that the
1957         thin pointer designates, but the components have been shifted so this
1958         is actually the opposite of the offset of the BOUNDS field.  */
1959       gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1960       gnu_result = size_binop (MINUS_EXPR, bitsize_zero_node,
1961                                bit_position (TYPE_FIELDS (gnu_type)));
1962       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1963       prefix_unused = true;
1964       break;
1965
1966     case Attr_Null_Parameter:
1967       /* This is just a zero cast to the pointer type for our prefix and
1968          dereferenced.  */
1969       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1970       gnu_result
1971         = build_unary_op (INDIRECT_REF, NULL_TREE,
1972                           convert (build_pointer_type (gnu_result_type),
1973                                    integer_zero_node));
1974       TREE_PRIVATE (gnu_result) = 1;
1975       break;
1976
1977     case Attr_Mechanism_Code:
1978       {
1979         int code;
1980         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1981
1982         prefix_unused = true;
1983         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1984         if (Present (Expressions (gnat_node)))
1985           {
1986             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1987
1988             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1989                  i--, gnat_obj = Next_Formal (gnat_obj))
1990               ;
1991           }
1992
1993         code = Mechanism (gnat_obj);
1994         if (code == Default)
1995           code = ((present_gnu_tree (gnat_obj)
1996                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1997                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1998                             == PARM_DECL)
1999                            && (DECL_BY_COMPONENT_PTR_P
2000                                (get_gnu_tree (gnat_obj))))))
2001                   ? By_Reference : By_Copy);
2002         gnu_result = convert (gnu_result_type, size_int (- code));
2003       }
2004       break;
2005
2006     default:
2007       /* Say we have an unimplemented attribute.  Then set the value to be
2008          returned to be a zero and hope that's something we can convert to
2009          the type of this attribute.  */
2010       post_error ("unimplemented attribute", gnat_node);
2011       gnu_result_type = get_unpadded_type (Etype (gnat_node));
2012       gnu_result = integer_zero_node;
2013       break;
2014     }
2015
2016   /* If this is an attribute where the prefix was unused, force a use of it if
2017      it has a side-effect.  But don't do it if the prefix is just an entity
2018      name.  However, if an access check is needed, we must do it.  See second
2019      example in AARM 11.6(5.e).  */
2020   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
2021       && !Is_Entity_Name (Prefix (gnat_node)))
2022     gnu_result = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix,
2023                                        gnu_result);
2024
2025   *gnu_result_type_p = gnu_result_type;
2026   return gnu_result;
2027 }
2028 \f
2029 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2030    to a GCC tree, which is returned.  */
2031
2032 static tree
2033 Case_Statement_to_gnu (Node_Id gnat_node)
2034 {
2035   tree gnu_result, gnu_expr, gnu_label;
2036   Node_Id gnat_when;
2037   location_t end_locus;
2038   bool may_fallthru = false;
2039
2040   gnu_expr = gnat_to_gnu (Expression (gnat_node));
2041   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2042
2043   /*  The range of values in a case statement is determined by the rules in
2044       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
2045       of the expression. One exception arises in the case of a simple name that
2046       is parenthesized. This still has the Etype of the name, but since it is
2047       not a name, para 7 does not apply, and we need to go to the base type.
2048       This is the only case where parenthesization affects the dynamic
2049       semantics (i.e. the range of possible values at run time that is covered
2050       by the others alternative).
2051
2052       Another exception is if the subtype of the expression is non-static.  In
2053       that case, we also have to use the base type.  */
2054   if (Paren_Count (Expression (gnat_node)) != 0
2055       || !Is_OK_Static_Subtype (Underlying_Type
2056                                 (Etype (Expression (gnat_node)))))
2057     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2058
2059   /* We build a SWITCH_EXPR that contains the code with interspersed
2060      CASE_LABEL_EXPRs for each label.  */
2061   if (!Sloc_to_locus (Sloc (gnat_node) + UI_To_Int (End_Span (gnat_node)),
2062       &end_locus))
2063     end_locus = input_location;
2064   gnu_label = create_artificial_label (end_locus);
2065   start_stmt_group ();
2066
2067   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2068        Present (gnat_when);
2069        gnat_when = Next_Non_Pragma (gnat_when))
2070     {
2071       bool choices_added_p = false;
2072       Node_Id gnat_choice;
2073
2074       /* First compile all the different case choices for the current WHEN
2075          alternative.  */
2076       for (gnat_choice = First (Discrete_Choices (gnat_when));
2077            Present (gnat_choice); gnat_choice = Next (gnat_choice))
2078         {
2079           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2080
2081           switch (Nkind (gnat_choice))
2082             {
2083             case N_Range:
2084               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2085               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2086               break;
2087
2088             case N_Subtype_Indication:
2089               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2090                                                 (Constraint (gnat_choice))));
2091               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2092                                                   (Constraint (gnat_choice))));
2093               break;
2094
2095             case N_Identifier:
2096             case N_Expanded_Name:
2097               /* This represents either a subtype range or a static value of
2098                  some kind; Ekind says which.  */
2099               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2100                 {
2101                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2102
2103                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
2104                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
2105                   break;
2106                 }
2107
2108               /* ... fall through ... */
2109
2110             case N_Character_Literal:
2111             case N_Integer_Literal:
2112               gnu_low = gnat_to_gnu (gnat_choice);
2113               break;
2114
2115             case N_Others_Choice:
2116               break;
2117
2118             default:
2119               gcc_unreachable ();
2120             }
2121
2122           /* If the case value is a subtype that raises Constraint_Error at
2123              run time because of a wrong bound, then gnu_low or gnu_high is
2124              not translated into an INTEGER_CST.  In such a case, we need
2125              to ensure that the when statement is not added in the tree,
2126              otherwise it will crash the gimplifier.  */
2127           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2128               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2129             {
2130               add_stmt_with_node (build_case_label
2131                                   (gnu_low, gnu_high,
2132                                    create_artificial_label (input_location)),
2133                                   gnat_choice);
2134               choices_added_p = true;
2135             }
2136         }
2137
2138       /* Push a binding level here in case variables are declared as we want
2139          them to be local to this set of statements instead of to the block
2140          containing the Case statement.  */
2141       if (choices_added_p)
2142         {
2143           tree group = build_stmt_group (Statements (gnat_when), true);
2144           bool group_may_fallthru = block_may_fallthru (group);
2145           add_stmt (group);
2146           if (group_may_fallthru)
2147             {
2148               tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2149               SET_EXPR_LOCATION (stmt, end_locus);
2150               add_stmt (stmt);
2151               may_fallthru = true;
2152             }
2153         }
2154     }
2155
2156   /* Now emit a definition of the label the cases branch to, if any.  */
2157   if (may_fallthru)
2158     add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2159   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2160                        end_stmt_group (), NULL_TREE);
2161
2162   return gnu_result;
2163 }
2164 \f
2165 /* Find out whether VAR is an iteration variable of an enclosing loop in the
2166    current function.  If so, push a range_check_info structure onto the stack
2167    of this enclosing loop and return it.  Otherwise, return NULL.  */
2168
2169 static struct range_check_info_d *
2170 push_range_check_info (tree var)
2171 {
2172   struct loop_info_d *iter = NULL;
2173   unsigned int i;
2174
2175   if (VEC_empty (loop_info, gnu_loop_stack))
2176     return NULL;
2177
2178   var = remove_conversions (var, false);
2179
2180   if (TREE_CODE (var) != VAR_DECL)
2181     return NULL;
2182
2183   if (decl_function_context (var) != current_function_decl)
2184     return NULL;
2185
2186   for (i = VEC_length (loop_info, gnu_loop_stack) - 1;
2187        VEC_iterate (loop_info, gnu_loop_stack, i, iter);
2188        i--)
2189     if (var == iter->loop_var)
2190       break;
2191
2192   if (iter)
2193     {
2194       struct range_check_info_d *rci = ggc_alloc_range_check_info_d ();
2195       VEC_safe_push (range_check_info, gc, iter->checks, rci);
2196       return rci;
2197     }
2198
2199   return NULL;
2200 }
2201
2202 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2203    false, or the maximum value if MAX is true, of TYPE.  */
2204
2205 static bool
2206 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2207 {
2208   tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2209
2210   if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2211     return true;
2212
2213   if (TREE_CODE (val) == NOP_EXPR)
2214     val = (max
2215            ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2216            : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2217
2218   if (TREE_CODE (val) != INTEGER_CST)
2219     return true;
2220
2221   return tree_int_cst_equal (val, min_or_max_val) == 1;
2222 }
2223
2224 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2225    If REVERSE is true, minimum value is taken as maximum value.  */
2226
2227 static inline bool
2228 can_equal_min_val_p (tree val, tree type, bool reverse)
2229 {
2230   return can_equal_min_or_max_val_p (val, type, reverse);
2231 }
2232
2233 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2234    If REVERSE is true, maximum value is taken as minimum value.  */
2235
2236 static inline bool
2237 can_equal_max_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 VAL1 can be lower than VAL2.  */
2243
2244 static bool
2245 can_be_lower_p (tree val1, tree val2)
2246 {
2247   if (TREE_CODE (val1) == NOP_EXPR)
2248     val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2249
2250   if (TREE_CODE (val1) != INTEGER_CST)
2251     return true;
2252
2253   if (TREE_CODE (val2) == NOP_EXPR)
2254     val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2255
2256   if (TREE_CODE (val2) != INTEGER_CST)
2257     return true;
2258
2259   return tree_int_cst_lt (val1, val2);
2260 }
2261
2262 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2263    to a GCC tree, which is returned.  */
2264
2265 static tree
2266 Loop_Statement_to_gnu (Node_Id gnat_node)
2267 {
2268   const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2269   struct loop_info_d *gnu_loop_info = ggc_alloc_cleared_loop_info_d ();
2270   tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2271                                NULL_TREE, NULL_TREE, NULL_TREE);
2272   tree gnu_loop_label = create_artificial_label (input_location);
2273   tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2274   tree gnu_result;
2275
2276   /* Push the loop_info structure associated with the LOOP_STMT.  */
2277   VEC_safe_push (loop_info, gc, gnu_loop_stack, gnu_loop_info);
2278
2279   /* Set location information for statement and end label.  */
2280   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2281   Sloc_to_locus (Sloc (End_Label (gnat_node)),
2282                  &DECL_SOURCE_LOCATION (gnu_loop_label));
2283   LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2284
2285   /* Save the label so that a corresponding N_Exit_Statement can find it.  */
2286   gnu_loop_info->label = gnu_loop_label;
2287
2288   /* Set the condition under which the loop must keep going.
2289      For the case "LOOP .... END LOOP;" the condition is always true.  */
2290   if (No (gnat_iter_scheme))
2291     ;
2292
2293   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2294   else if (Present (Condition (gnat_iter_scheme)))
2295     LOOP_STMT_COND (gnu_loop_stmt)
2296       = gnat_to_gnu (Condition (gnat_iter_scheme));
2297
2298   /* Otherwise we have an iteration scheme and the condition is given by the
2299      bounds of the subtype of the iteration variable.  */
2300   else
2301     {
2302       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2303       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2304       Entity_Id gnat_type = Etype (gnat_loop_var);
2305       tree gnu_type = get_unpadded_type (gnat_type);
2306       tree gnu_base_type = get_base_type (gnu_type);
2307       tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2308       tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2309       enum tree_code update_code, test_code, shift_code;
2310       bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2311
2312       gnu_low = TYPE_MIN_VALUE (gnu_type);
2313       gnu_high = TYPE_MAX_VALUE (gnu_type);
2314
2315       /* We must disable modulo reduction for the iteration variable, if any,
2316          in order for the loop comparison to be effective.  */
2317       if (reverse)
2318         {
2319           gnu_first = gnu_high;
2320           gnu_last = gnu_low;
2321           update_code = MINUS_NOMOD_EXPR;
2322           test_code = GE_EXPR;
2323           shift_code = PLUS_NOMOD_EXPR;
2324         }
2325       else
2326         {
2327           gnu_first = gnu_low;
2328           gnu_last = gnu_high;
2329           update_code = PLUS_NOMOD_EXPR;
2330           test_code = LE_EXPR;
2331           shift_code = MINUS_NOMOD_EXPR;
2332         }
2333
2334       /* We use two different strategies to translate the loop, depending on
2335          whether optimization is enabled.
2336
2337          If it is, we generate the canonical loop form expected by the loop
2338          optimizer and the loop vectorizer, which is the do-while form:
2339
2340              ENTRY_COND
2341            loop:
2342              TOP_UPDATE
2343              BODY
2344              BOTTOM_COND
2345              GOTO loop
2346
2347          This avoids an implicit dependency on loop header copying and makes
2348          it possible to turn BOTTOM_COND into an inequality test.
2349
2350          If optimization is disabled, loop header copying doesn't come into
2351          play and we try to generate the loop form with the fewer conditional
2352          branches.  First, the default form, which is:
2353
2354            loop:
2355              TOP_COND
2356              BODY
2357              BOTTOM_UPDATE
2358              GOTO loop
2359
2360          It should catch most loops with constant ending point.  Then, if we
2361          cannot, we try to generate the shifted form:
2362
2363            loop:
2364              TOP_COND
2365              TOP_UPDATE
2366              BODY
2367              GOTO loop
2368
2369          which should catch loops with constant starting point.  Otherwise, if
2370          we cannot, we generate the fallback form:
2371
2372              ENTRY_COND
2373            loop:
2374              BODY
2375              BOTTOM_COND
2376              BOTTOM_UPDATE
2377              GOTO loop
2378
2379          which works in all cases.  */
2380
2381       if (optimize)
2382         {
2383           /* We can use the do-while form directly if GNU_FIRST-1 doesn't
2384              overflow.  */
2385           if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2386             ;
2387
2388           /* Otherwise, use the do-while form with the help of a special
2389              induction variable in the unsigned version of the base type
2390              or the unsigned version of sizetype, whichever is the
2391              largest, in order to have wrap-around arithmetics for it.  */
2392           else
2393             {
2394               if (TYPE_PRECISION (gnu_base_type) > TYPE_PRECISION (sizetype))
2395                 gnu_base_type = gnat_unsigned_type (gnu_base_type);
2396               else
2397                 gnu_base_type = sizetype;
2398
2399               gnu_first = convert (gnu_base_type, gnu_first);
2400               gnu_last = convert (gnu_base_type, gnu_last);
2401               gnu_one_node = convert (gnu_base_type, integer_one_node);
2402               use_iv = true;
2403             }
2404
2405           gnu_first
2406             = build_binary_op (shift_code, gnu_base_type, gnu_first,
2407                                gnu_one_node);
2408           LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2409           LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2410         }
2411       else
2412         {
2413           /* We can use the default form if GNU_LAST+1 doesn't overflow.  */
2414           if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2415             ;
2416
2417           /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2418              GNU_LAST-1 does.  */
2419           else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2420                    && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2421             {
2422               gnu_first
2423                 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2424                                    gnu_one_node);
2425               gnu_last
2426                 = build_binary_op (shift_code, gnu_base_type, gnu_last,
2427                                    gnu_one_node);
2428               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2429             }
2430
2431           /* Otherwise, use the fallback form.  */
2432           else
2433             LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2434         }
2435
2436       /* If we use the BOTTOM_COND, we can turn the test into an inequality
2437          test but we may have to add ENTRY_COND to protect the empty loop.  */
2438       if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2439         {
2440           test_code = NE_EXPR;
2441           if (can_be_lower_p (gnu_high, gnu_low))
2442             {
2443               gnu_cond_expr
2444                 = build3 (COND_EXPR, void_type_node,
2445                           build_binary_op (LE_EXPR, boolean_type_node,
2446                                            gnu_low, gnu_high),
2447                           NULL_TREE, alloc_stmt_list ());
2448               set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2449             }
2450         }
2451
2452       /* Open a new nesting level that will surround the loop to declare the
2453          iteration variable.  */
2454       start_stmt_group ();
2455       gnat_pushlevel ();
2456
2457       /* If we use the special induction variable, create it and set it to
2458          its initial value.  Morever, the regular iteration variable cannot
2459          itself be initialized, lest the initial value wrapped around.  */
2460       if (use_iv)
2461         {
2462           gnu_loop_iv
2463             = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
2464           add_stmt (gnu_stmt);
2465           gnu_first = NULL_TREE;
2466         }
2467       else
2468         gnu_loop_iv = NULL_TREE;
2469
2470       /* Declare the iteration variable and set it to its initial value.  */
2471       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2472       if (DECL_BY_REF_P (gnu_loop_var))
2473         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2474       else if (use_iv)
2475         {
2476           gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
2477           SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
2478         }
2479       gnu_loop_info->loop_var = gnu_loop_var;
2480
2481       /* Do all the arithmetics in the base type.  */
2482       gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2483
2484       /* Set either the top or bottom exit condition.  */
2485       if (use_iv)
2486         LOOP_STMT_COND (gnu_loop_stmt)
2487           = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
2488                              gnu_last);
2489       else
2490         LOOP_STMT_COND (gnu_loop_stmt)
2491           = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2492                              gnu_last);
2493
2494       /* Set either the top or bottom update statement and give it the source
2495          location of the iteration for better coverage info.  */
2496       if (use_iv)
2497         {
2498           gnu_stmt
2499             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
2500                                build_binary_op (update_code, gnu_base_type,
2501                                                 gnu_loop_iv, gnu_one_node));
2502           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2503           append_to_statement_list (gnu_stmt,
2504                                     &LOOP_STMT_UPDATE (gnu_loop_stmt));
2505           gnu_stmt
2506             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2507                                gnu_loop_iv);
2508           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2509           append_to_statement_list (gnu_stmt,
2510                                     &LOOP_STMT_UPDATE (gnu_loop_stmt));
2511         }
2512       else
2513         {
2514           gnu_stmt
2515             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2516                                build_binary_op (update_code, gnu_base_type,
2517                                                 gnu_loop_var, gnu_one_node));
2518           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2519           LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
2520         }
2521     }
2522
2523   /* If the loop was named, have the name point to this loop.  In this case,
2524      the association is not a DECL node, but the end label of the loop.  */
2525   if (Present (Identifier (gnat_node)))
2526     save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2527
2528   /* Make the loop body into its own block, so any allocated storage will be
2529      released every iteration.  This is needed for stack allocation.  */
2530   LOOP_STMT_BODY (gnu_loop_stmt)
2531     = build_stmt_group (Statements (gnat_node), true);
2532   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2533
2534   /* If we have an iteration scheme, then we are in a statement group.  Add
2535      the LOOP_STMT to it, finish it and make it the "loop".  */
2536   if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
2537     {
2538       struct range_check_info_d *rci;
2539       unsigned n_checks = VEC_length (range_check_info, gnu_loop_info->checks);
2540       unsigned int i;
2541
2542       /* First, if we have computed a small number of invariant conditions for
2543          range checks applied to the iteration variable, then initialize these
2544          conditions in front of the loop.  Otherwise, leave them set to True.
2545
2546          ??? The heuristics need to be improved, by taking into account the
2547              following datapoints:
2548                - loop unswitching is disabled for big loops.  The cap is the
2549                  parameter PARAM_MAX_UNSWITCH_INSNS (50).
2550                - loop unswitching can only be applied a small number of times
2551                  to a given loop.  The cap is PARAM_MAX_UNSWITCH_LEVEL (3).
2552                - the front-end quickly generates useless or redundant checks
2553                  that can be entirely optimized away in the end.  */
2554       if (1 <= n_checks && n_checks <= 4)
2555         for (i = 0;
2556              VEC_iterate (range_check_info, gnu_loop_info->checks, i, rci);
2557              i++)
2558           {
2559             tree low_ok
2560               = build_binary_op (GE_EXPR, boolean_type_node,
2561                                  convert (rci->type, gnu_low),
2562                                  rci->low_bound);
2563             tree high_ok
2564               = build_binary_op (LE_EXPR, boolean_type_node,
2565                                  convert (rci->type, gnu_high),
2566                                  rci->high_bound);
2567             tree range_ok
2568               = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
2569                                  low_ok, high_ok);
2570
2571             TREE_OPERAND (rci->invariant_cond, 0)
2572               = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
2573
2574             add_stmt_with_node_force (rci->invariant_cond, gnat_node);
2575           }
2576
2577       add_stmt (gnu_loop_stmt);
2578       gnat_poplevel ();
2579       gnu_loop_stmt = end_stmt_group ();
2580     }
2581
2582   /* If we have an outer COND_EXPR, that's our result and this loop is its
2583      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2584   if (gnu_cond_expr)
2585     {
2586       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2587       gnu_result = gnu_cond_expr;
2588       recalculate_side_effects (gnu_cond_expr);
2589     }
2590   else
2591     gnu_result = gnu_loop_stmt;
2592
2593   VEC_pop (loop_info, gnu_loop_stack);
2594
2595   return gnu_result;
2596 }
2597 \f
2598 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2599    handler for the current function.  */
2600
2601 /* This is implemented by issuing a call to the appropriate VMS specific
2602    builtin.  To avoid having VMS specific sections in the global gigi decls
2603    array, we maintain the decls of interest here.  We can't declare them
2604    inside the function because we must mark them never to be GC'd, which we
2605    can only do at the global level.  */
2606
2607 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2608 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2609
2610 static void
2611 establish_gnat_vms_condition_handler (void)
2612 {
2613   tree establish_stmt;
2614
2615   /* Elaborate the required decls on the first call.  Check on the decl for
2616      the gnat condition handler to decide, as this is one we create so we are
2617      sure that it will be non null on subsequent calls.  The builtin decl is
2618      looked up so remains null on targets where it is not implemented yet.  */
2619   if (gnat_vms_condition_handler_decl == NULL_TREE)
2620     {
2621       vms_builtin_establish_handler_decl
2622         = builtin_decl_for
2623           (get_identifier ("__builtin_establish_vms_condition_handler"));
2624
2625       gnat_vms_condition_handler_decl
2626         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2627                                NULL_TREE,
2628                                build_function_type_list (boolean_type_node,
2629                                                          ptr_void_type_node,
2630                                                          ptr_void_type_node,
2631                                                          NULL_TREE),
2632                                NULL_TREE, false, true, true, true, NULL,
2633                                Empty);
2634
2635       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2636       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2637     }
2638
2639   /* Do nothing if the establish builtin is not available, which might happen
2640      on targets where the facility is not implemented.  */
2641   if (vms_builtin_establish_handler_decl == NULL_TREE)
2642     return;
2643
2644   establish_stmt
2645     = build_call_n_expr (vms_builtin_establish_handler_decl, 1,
2646                          build_unary_op
2647                          (ADDR_EXPR, NULL_TREE,
2648                           gnat_vms_condition_handler_decl));
2649
2650   add_stmt (establish_stmt);
2651 }
2652
2653 /* This page implements a form of Named Return Value optimization modelled
2654    on the C++ optimization of the same name.  The main difference is that
2655    we disregard any semantical considerations when applying it here, the
2656    counterpart being that we don't try to apply it to semantically loaded
2657    return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
2658
2659    We consider a function body of the following GENERIC form:
2660
2661      return_type R1;
2662        [...]
2663      RETURN_EXPR [<retval> = ...]
2664        [...]
2665      RETURN_EXPR [<retval> = R1]
2666        [...]
2667      return_type Ri;
2668        [...]
2669      RETURN_EXPR [<retval> = ...]
2670        [...]
2671      RETURN_EXPR [<retval> = Ri]
2672        [...]
2673
2674    and we try to fulfill a simple criterion that would make it possible to
2675    replace one or several Ri variables with the RESULT_DECL of the function.
2676
2677    The first observation is that RETURN_EXPRs that don't directly reference
2678    any of the Ri variables on the RHS of their assignment are transparent wrt
2679    the optimization.  This is because the Ri variables aren't addressable so
2680    any transformation applied to them doesn't affect the RHS; moreover, the
2681    assignment writes the full <retval> object so existing values are entirely
2682    discarded.
2683
2684    This property can be extended to some forms of RETURN_EXPRs that reference
2685    the Ri variables, for example CONSTRUCTORs, but isn't true in the general
2686    case, in particular when function calls are involved.
2687
2688    Therefore the algorithm is as follows:
2689
2690      1. Collect the list of candidates for a Named Return Value (Ri variables
2691         on the RHS of assignments of RETURN_EXPRs) as well as the list of the
2692         other expressions on the RHS of such assignments.
2693
2694      2. Prune the members of the first list (candidates) that are referenced
2695         by a member of the second list (expressions).
2696
2697      3. Extract a set of candidates with non-overlapping live ranges from the
2698         first list.  These are the Named Return Values.
2699
2700      4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
2701         Named Return Values in the function with the RESULT_DECL.
2702
2703    If the function returns an unconstrained type, things are a bit different
2704    because the anonymous return object is allocated on the secondary stack
2705    and RESULT_DECL is only a pointer to it.  Each return object can be of a
2706    different size and is allocated separately so we need not care about the
2707    aforementioned overlapping issues.  Therefore, we don't collect the other
2708    expressions and skip step #2 in the algorithm.  */
2709
2710 struct nrv_data
2711 {
2712   bitmap nrv;
2713   tree result;
2714   Node_Id gnat_ret;
2715   struct pointer_set_t *visited;
2716 };
2717
2718 /* Return true if T is a Named Return Value.  */
2719
2720 static inline bool
2721 is_nrv_p (bitmap nrv, tree t)
2722 {
2723   return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
2724 }
2725
2726 /* Helper function for walk_tree, used by finalize_nrv below.  */
2727
2728 static tree
2729 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
2730 {
2731   struct nrv_data *dp = (struct nrv_data *)data;
2732   tree t = *tp;
2733
2734   /* No need to walk into types or decls.  */
2735   if (IS_TYPE_OR_DECL_P (t))
2736     *walk_subtrees = 0;
2737
2738   if (is_nrv_p (dp->nrv, t))
2739     bitmap_clear_bit (dp->nrv, DECL_UID (t));
2740
2741   return NULL_TREE;
2742 }
2743
2744 /* Prune Named Return Values in BLOCK and return true if there is still a
2745    Named Return Value in BLOCK or one of its sub-blocks.  */
2746
2747 static bool
2748 prune_nrv_in_block (bitmap nrv, tree block)
2749 {
2750   bool has_nrv = false;
2751   tree t;
2752
2753   /* First recurse on the sub-blocks.  */
2754   for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
2755     has_nrv |= prune_nrv_in_block (nrv, t);
2756
2757   /* Then make sure to keep at most one NRV per block.  */
2758   for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
2759     if (is_nrv_p (nrv, t))
2760       {
2761         if (has_nrv)
2762           bitmap_clear_bit (nrv, DECL_UID (t));
2763         else
2764           has_nrv = true;
2765       }
2766
2767   return has_nrv;
2768 }
2769
2770 /* Helper function for walk_tree, used by finalize_nrv below.  */
2771
2772 static tree
2773 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
2774 {
2775   struct nrv_data *dp = (struct nrv_data *)data;
2776   tree t = *tp;
2777
2778   /* No need to walk into types.  */
2779   if (TYPE_P (t))
2780     *walk_subtrees = 0;
2781
2782   /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
2783      nop, but differs from using NULL_TREE in that it indicates that we care
2784      about the value of the RESULT_DECL.  */
2785   else if (TREE_CODE (t) == RETURN_EXPR
2786            && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
2787     {
2788       tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1), init_expr;
2789
2790       /* If this is the temporary created for a return value with variable
2791          size in call_to_gnu, we replace the RHS with the init expression.  */
2792       if (TREE_CODE (ret_val) == COMPOUND_EXPR
2793           && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
2794           && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
2795              == TREE_OPERAND (ret_val, 1))
2796         {
2797           init_expr = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
2798           ret_val = TREE_OPERAND (ret_val, 1);
2799         }
2800       else
2801         init_expr = NULL_TREE;
2802
2803       /* Strip useless conversions around the return value.  */
2804       if (gnat_useless_type_conversion (ret_val))
2805         ret_val = TREE_OPERAND (ret_val, 0);
2806
2807       if (is_nrv_p (dp->nrv, ret_val))
2808         {
2809           if (init_expr)
2810             TREE_OPERAND (TREE_OPERAND (t, 0), 1) = init_expr;
2811           else
2812             TREE_OPERAND (t, 0) = dp->result;
2813         }
2814     }
2815
2816   /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
2817      if needed.  */
2818   else if (TREE_CODE (t) == DECL_EXPR
2819            && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
2820     {
2821       tree var = DECL_EXPR_DECL (t), init;
2822
2823       if (DECL_INITIAL (var))
2824         {
2825           init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
2826                                   DECL_INITIAL (var));
2827           SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
2828           DECL_INITIAL (var) = NULL_TREE;
2829         }
2830       else
2831         init = build_empty_stmt (EXPR_LOCATION (t));
2832       *tp = init;
2833
2834       /* Identify the NRV to the RESULT_DECL for debugging purposes.  */
2835       SET_DECL_VALUE_EXPR (var, dp->result);
2836       DECL_HAS_VALUE_EXPR_P (var) = 1;
2837       /* ??? Kludge to avoid an assertion failure during inlining.  */
2838       DECL_SIZE (var) = bitsize_unit_node;
2839       DECL_SIZE_UNIT (var) = size_one_node;
2840     }
2841
2842   /* And replace all uses of NRVs with the RESULT_DECL.  */
2843   else if (is_nrv_p (dp->nrv, t))
2844     *tp = convert (TREE_TYPE (t), dp->result);
2845
2846   /* Avoid walking into the same tree more than once.  Unfortunately, we
2847      can't just use walk_tree_without_duplicates because it would only
2848      call us for the first occurrence of NRVs in the function body.  */
2849   if (pointer_set_insert (dp->visited, *tp))
2850     *walk_subtrees = 0;
2851
2852   return NULL_TREE;
2853 }
2854
2855 /* Likewise, but used when the function returns an unconstrained type.  */
2856
2857 static tree
2858 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
2859 {
2860   struct nrv_data *dp = (struct nrv_data *)data;
2861   tree t = *tp;
2862
2863   /* No need to walk into types.  */
2864   if (TYPE_P (t))
2865     *walk_subtrees = 0;
2866
2867   /* We need to see the DECL_EXPR of NRVs before any other references so we
2868      walk the body of BIND_EXPR before walking its variables.  */
2869   else if (TREE_CODE (t) == BIND_EXPR)
2870     walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
2871
2872   /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
2873      return value built by the allocator instead of the whole construct.  */
2874   else if (TREE_CODE (t) == RETURN_EXPR
2875            && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
2876     {
2877       tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
2878
2879       /* This is the construct returned by the allocator.  */
2880       if (TREE_CODE (ret_val) == COMPOUND_EXPR
2881           && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
2882         {
2883           if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
2884             ret_val
2885               = VEC_index (constructor_elt,
2886                            CONSTRUCTOR_ELTS
2887                            (TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1)),
2888                             1)->value;
2889           else
2890             ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
2891         }
2892
2893       /* Strip useless conversions around the return value.  */
2894       if (gnat_useless_type_conversion (ret_val)
2895           || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
2896         ret_val = TREE_OPERAND (ret_val, 0);
2897
2898       /* Strip unpadding around the return value.  */
2899       if (TREE_CODE (ret_val) == COMPONENT_REF
2900           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
2901         ret_val = TREE_OPERAND (ret_val, 0);
2902
2903       /* Assign the new return value to the RESULT_DECL.  */
2904       if (is_nrv_p (dp->nrv, ret_val))
2905         TREE_OPERAND (TREE_OPERAND (t, 0), 1)
2906           = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
2907     }
2908
2909   /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
2910      into a new variable.  */
2911   else if (TREE_CODE (t) == DECL_EXPR
2912            && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
2913     {
2914       tree saved_current_function_decl = current_function_decl;
2915       tree var = DECL_EXPR_DECL (t);
2916       tree alloc, p_array, new_var, new_ret;
2917       VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
2918
2919       /* Create an artificial context to build the allocation.  */
2920       current_function_decl = decl_function_context (var);
2921       start_stmt_group ();
2922       gnat_pushlevel ();
2923
2924       /* This will return a COMPOUND_EXPR with the allocation in the first
2925          arm and the final return value in the second arm.  */
2926       alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
2927                                TREE_TYPE (dp->result),
2928                                Procedure_To_Call (dp->gnat_ret),
2929                                Storage_Pool (dp->gnat_ret),
2930                                Empty, false);
2931
2932       /* The new variable is built as a reference to the allocated space.  */
2933       new_var
2934         = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
2935                       build_reference_type (TREE_TYPE (var)));
2936       DECL_BY_REFERENCE (new_var) = 1;
2937
2938       if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
2939         {
2940           /* The new initial value is a COMPOUND_EXPR with the allocation in
2941              the first arm and the value of P_ARRAY in the second arm.  */
2942           DECL_INITIAL (new_var)
2943             = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
2944                       TREE_OPERAND (alloc, 0),
2945                       VEC_index (constructor_elt,
2946                                  CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)),
2947                                                    0)->value);
2948
2949           /* Build a modified CONSTRUCTOR that references NEW_VAR.  */
2950           p_array = TYPE_FIELDS (TREE_TYPE (alloc));
2951           CONSTRUCTOR_APPEND_ELT (v, p_array,
2952                                   fold_convert (TREE_TYPE (p_array), new_var));
2953           CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
2954                                   VEC_index (constructor_elt,
2955                                              CONSTRUCTOR_ELTS
2956                                              (TREE_OPERAND (alloc, 1)),
2957                                               1)->value);
2958           new_ret = build_constructor (TREE_TYPE (alloc), v);
2959         }
2960       else
2961         {
2962           /* The new initial value is just the allocation.  */
2963           DECL_INITIAL (new_var) = alloc;
2964           new_ret = fold_convert (TREE_TYPE (alloc), new_var);
2965         }
2966
2967       gnat_pushdecl (new_var, Empty);
2968
2969       /* Destroy the artificial context and insert the new statements.  */
2970       gnat_zaplevel ();
2971       *tp = end_stmt_group ();
2972       current_function_decl = saved_current_function_decl;
2973
2974       /* Chain NEW_VAR immediately after VAR and ignore the latter.  */
2975       DECL_CHAIN (new_var) = DECL_CHAIN (var);
2976       DECL_CHAIN (var) = new_var;
2977       DECL_IGNORED_P (var) = 1;
2978
2979       /* Save the new return value and the dereference of NEW_VAR.  */
2980       DECL_INITIAL (var)
2981         = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
2982                   build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
2983       /* ??? Kludge to avoid messing up during inlining.  */
2984       DECL_CONTEXT (var) = NULL_TREE;
2985     }
2986
2987   /* And replace all uses of NRVs with the dereference of NEW_VAR.  */
2988   else if (is_nrv_p (dp->nrv, t))
2989     *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
2990
2991   /* Avoid walking into the same tree more than once.  Unfortunately, we
2992      can't just use walk_tree_without_duplicates because it would only
2993      call us for the first occurrence of NRVs in the function body.  */
2994   if (pointer_set_insert (dp->visited, *tp))
2995     *walk_subtrees = 0;
2996
2997   return NULL_TREE;
2998 }
2999
3000 /* Finalize the Named Return Value optimization for FNDECL.  The NRV bitmap
3001    contains the candidates for Named Return Value and OTHER is a list of
3002    the other return values.  GNAT_RET is a representative return node.  */
3003
3004 static void
3005 finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other, Node_Id gnat_ret)
3006 {
3007   struct cgraph_node *node;
3008   struct nrv_data data;
3009   walk_tree_fn func;
3010   unsigned int i;
3011   tree iter;
3012
3013   /* We shouldn't be applying the optimization to return types that we aren't
3014      allowed to manipulate freely.  */
3015   gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3016
3017   /* Prune the candidates that are referenced by other return values.  */
3018   data.nrv = nrv;
3019   data.result = NULL_TREE;
3020   data.visited = NULL;
3021   for (i = 0; VEC_iterate(tree, other, i, iter); i++)
3022     walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3023   if (bitmap_empty_p (nrv))
3024     return;
3025
3026   /* Prune also the candidates that are referenced by nested functions.  */
3027   node = cgraph_get_create_node (fndecl);
3028   for (node = node->nested; node; node = node->next_nested)
3029     walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r,
3030                                   &data);
3031   if (bitmap_empty_p (nrv))
3032     return;
3033
3034   /* Extract a set of NRVs with non-overlapping live ranges.  */
3035   if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3036     return;
3037
3038   /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs.  */
3039   data.nrv = nrv;
3040   data.result = DECL_RESULT (fndecl);
3041   data.gnat_ret = gnat_ret;
3042   data.visited = pointer_set_create ();
3043   if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3044     func = finalize_nrv_unc_r;
3045   else
3046     func = finalize_nrv_r;
3047   walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3048   pointer_set_destroy (data.visited);
3049 }
3050
3051 /* Return true if RET_VAL can be used as a Named Return Value for the
3052    anonymous return object RET_OBJ.  */
3053
3054 static bool
3055 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3056 {
3057   if (TREE_CODE (ret_val) != VAR_DECL)
3058     return false;
3059
3060   if (TREE_THIS_VOLATILE (ret_val))
3061     return false;
3062
3063   if (DECL_CONTEXT (ret_val) != current_function_decl)
3064     return false;
3065
3066   if (TREE_STATIC (ret_val))
3067     return false;
3068
3069   if (TREE_ADDRESSABLE (ret_val))
3070     return false;
3071
3072   if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3073     return false;
3074
3075   return true;
3076 }
3077
3078 /* Build a RETURN_EXPR.  If RET_VAL is non-null, build a RETURN_EXPR around
3079    the assignment of RET_VAL to RET_OBJ.  Otherwise build a bare RETURN_EXPR
3080    around RESULT_OBJ, which may be null in this case.  */
3081
3082 static tree
3083 build_return_expr (tree ret_obj, tree ret_val)
3084 {
3085   tree result_expr;
3086
3087   if (ret_val)
3088     {
3089       /* The gimplifier explicitly enforces the following invariant:
3090
3091               RETURN_EXPR
3092                   |
3093               MODIFY_EXPR
3094               /        \
3095              /          \
3096          RET_OBJ        ...
3097
3098          As a consequence, type consistency dictates that we use the type
3099          of the RET_OBJ as the operation type.  */
3100       tree operation_type = TREE_TYPE (ret_obj);
3101
3102       /* Convert the right operand to the operation type.  Note that it's the
3103          same transformation as in the MODIFY_EXPR case of build_binary_op,
3104          with the assumption that the type cannot involve a placeholder.  */
3105       if (operation_type != TREE_TYPE (ret_val))
3106         ret_val = convert (operation_type, ret_val);
3107
3108       result_expr = build2 (MODIFY_EXPR, void_type_node, ret_obj, ret_val);
3109
3110       /* If the function returns an aggregate type, find out whether this is
3111          a candidate for Named Return Value.  If so, record it.  Otherwise,
3112          if this is an expression of some kind, record it elsewhere.  */
3113       if (optimize
3114           && AGGREGATE_TYPE_P (operation_type)
3115           && !TYPE_IS_FAT_POINTER_P (operation_type)
3116           && aggregate_value_p (operation_type, current_function_decl))
3117         {
3118           /* Recognize the temporary created for a return value with variable
3119              size in call_to_gnu.  We want to eliminate it if possible.  */
3120           if (TREE_CODE (ret_val) == COMPOUND_EXPR
3121               && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3122               && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3123                  == TREE_OPERAND (ret_val, 1))
3124             ret_val = TREE_OPERAND (ret_val, 1);
3125
3126           /* Strip useless conversions around the return value.  */
3127           if (gnat_useless_type_conversion (ret_val))
3128             ret_val = TREE_OPERAND (ret_val, 0);
3129
3130           /* Now apply the test to the return value.  */
3131           if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3132             {
3133               if (!f_named_ret_val)
3134                 f_named_ret_val = BITMAP_GGC_ALLOC ();
3135               bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3136             }
3137
3138           /* Note that we need not care about CONSTRUCTORs here, as they are
3139              totally transparent given the read-compose-write semantics of
3140              assignments from CONSTRUCTORs.  */
3141           else if (EXPR_P (ret_val))
3142             VEC_safe_push (tree, gc, f_other_ret_val, ret_val);
3143         }
3144     }
3145   else
3146     result_expr = ret_obj;
3147
3148   return build1 (RETURN_EXPR, void_type_node, result_expr);
3149 }
3150
3151 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
3152    and the GNAT node GNAT_SUBPROG.  */
3153
3154 static void
3155 build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
3156 {
3157   tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
3158   tree gnu_subprog_param, gnu_stub_param, gnu_param;
3159   tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
3160   VEC(tree,gc) *gnu_param_vec = NULL;
3161
3162   gnu_subprog_type = TREE_TYPE (gnu_subprog);
3163
3164   /* Initialize the information structure for the function.  */
3165   allocate_struct_function (gnu_stub_decl, false);
3166   set_cfun (NULL);
3167
3168   begin_subprog_body (gnu_stub_decl);
3169
3170   start_stmt_group ();
3171   gnat_pushlevel ();
3172
3173   /* Loop over the parameters of the stub and translate any of them
3174      passed by descriptor into a by reference one.  */
3175   for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
3176        gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog);
3177        gnu_stub_param;
3178        gnu_stub_param = DECL_CHAIN (gnu_stub_param),
3179        gnu_subprog_param = DECL_CHAIN (gnu_subprog_param))
3180     {
3181       if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
3182         {
3183           gcc_assert (DECL_BY_REF_P (gnu_subprog_param));
3184           gnu_param
3185             = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param),
3186                                       gnu_stub_param,
3187                                       DECL_PARM_ALT_TYPE (gnu_stub_param),
3188                                       DECL_BY_DOUBLE_REF_P (gnu_subprog_param),
3189                                       gnat_subprog);
3190         }
3191       else
3192         gnu_param = gnu_stub_param;
3193
3194       VEC_safe_push (tree, gc, gnu_param_vec, gnu_param);
3195     }
3196
3197   /* Invoke the internal subprogram.  */
3198   gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
3199                              gnu_subprog);
3200   gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type),
3201                                      gnu_subprog_addr, gnu_param_vec);
3202
3203   /* Propagate the return value, if any.  */
3204   if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
3205     add_stmt (gnu_subprog_call);
3206   else
3207     add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl),
3208                                  gnu_subprog_call));
3209
3210   gnat_poplevel ();
3211   end_subprog_body (end_stmt_group ());
3212   rest_of_subprog_body_compilation (gnu_stub_decl);
3213 }
3214 \f
3215 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
3216    don't return anything.  */
3217
3218 static void
3219 Subprogram_Body_to_gnu (Node_Id gnat_node)
3220 {
3221   /* Defining identifier of a parameter to the subprogram.  */
3222   Entity_Id gnat_param;
3223   /* The defining identifier for the subprogram body. Note that if a
3224      specification has appeared before for this body, then the identifier
3225      occurring in that specification will also be a defining identifier and all
3226      the calls to this subprogram will point to that specification.  */
3227   Entity_Id gnat_subprog_id
3228     = (Present (Corresponding_Spec (gnat_node))
3229        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3230   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
3231   tree gnu_subprog_decl;
3232   /* Its RESULT_DECL node.  */
3233   tree gnu_result_decl;
3234   /* Its FUNCTION_TYPE node.  */
3235   tree gnu_subprog_type;
3236   /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any.  */
3237   tree gnu_cico_list;
3238   /* The entry in the CI_CO_LIST that represents a function return, if any.  */
3239   tree gnu_return_var_elmt = NULL_TREE;
3240   tree gnu_result;
3241   struct language_function *gnu_subprog_language;
3242   VEC(parm_attr,gc) *cache;
3243
3244   /* If this is a generic object or if it has been eliminated,
3245      ignore it.  */
3246   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
3247       || Ekind (gnat_subprog_id) == E_Generic_Function
3248       || Is_Eliminated (gnat_subprog_id))
3249     return;
3250
3251   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
3252      the already-elaborated tree node.  However, if this subprogram had its
3253      elaboration deferred, we will already have made a tree node for it.  So
3254      treat it as not being defined in that case.  Such a subprogram cannot
3255      have an address clause or a freeze node, so this test is safe, though it
3256      does disable some otherwise-useful error checking.  */
3257   gnu_subprog_decl
3258     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
3259                           Acts_As_Spec (gnat_node)
3260                           && !present_gnu_tree (gnat_subprog_id));
3261   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
3262   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
3263   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3264   if (gnu_cico_list)
3265     gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list);
3266
3267   /* If the function returns by invisible reference, make it explicit in the
3268      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.
3269      Handle the explicit case here and the copy-in/copy-out case below.  */
3270   if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt)
3271     {
3272       TREE_TYPE (gnu_result_decl)
3273         = build_reference_type (TREE_TYPE (gnu_result_decl));
3274       relayout_decl (gnu_result_decl);
3275     }
3276
3277   /* Set the line number in the decl to correspond to that of the body so that
3278      the line number notes are written correctly.  */
3279   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
3280
3281   /* Initialize the information structure for the function.  */
3282   allocate_struct_function (gnu_subprog_decl, false);
3283   gnu_subprog_language = ggc_alloc_cleared_language_function ();
3284   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
3285   set_cfun (NULL);
3286
3287   begin_subprog_body (gnu_subprog_decl);
3288
3289   /* If there are In Out or Out parameters, we need to ensure that the return
3290      statement properly copies them out.  We do this by making a new block and
3291      converting any return into a goto to a label at the end of the block.  */
3292   if (gnu_cico_list)
3293     {
3294       tree gnu_return_var = NULL_TREE;
3295
3296       VEC_safe_push (tree, gc, gnu_return_label_stack,
3297                      create_artificial_label (input_location));
3298
3299       start_stmt_group ();
3300       gnat_pushlevel ();
3301
3302       /* If this is a function with In Out or Out parameters, we also need a
3303          variable for the return value to be placed.  */
3304       if (gnu_return_var_elmt)
3305         {
3306           tree gnu_return_type
3307             = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3308
3309           /* If the function returns by invisible reference, make it
3310              explicit in the function body.  See gnat_to_gnu_entity,
3311              E_Subprogram_Type case.  */
3312           if (TREE_ADDRESSABLE (gnu_subprog_type))
3313             gnu_return_type = build_reference_type (gnu_return_type);
3314
3315           gnu_return_var
3316             = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3317                                gnu_return_type, NULL_TREE, false, false,
3318                                false, false, NULL, gnat_subprog_id);
3319           TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3320         }
3321
3322       VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var);
3323
3324       /* See whether there are parameters for which we don't have a GCC tree
3325          yet.  These must be Out parameters.  Make a VAR_DECL for them and
3326          put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3327          We can match up the entries because TYPE_CI_CO_LIST is in the order
3328          of the parameters.  */
3329       for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3330            Present (gnat_param);
3331            gnat_param = Next_Formal_With_Extras (gnat_param))
3332         if (!present_gnu_tree (gnat_param))
3333           {
3334             tree gnu_cico_entry = gnu_cico_list;
3335
3336             /* Skip any entries that have been already filled in; they must
3337                correspond to In Out parameters.  */
3338             while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3339               gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3340
3341             /* Do any needed references for padded types.  */
3342             TREE_VALUE (gnu_cico_entry)
3343               = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)),
3344                          gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
3345           }
3346     }
3347   else
3348     VEC_safe_push (tree, gc, gnu_return_label_stack, NULL_TREE);
3349
3350   /* Get a tree corresponding to the code for the subprogram.  */
3351   start_stmt_group ();
3352   gnat_pushlevel ();
3353
3354   /* On VMS, establish our condition handler to possibly turn a condition into
3355      the corresponding exception if the subprogram has a foreign convention or
3356      is exported.
3357
3358      To ensure proper execution of local finalizations on condition instances,
3359      we must turn a condition into the corresponding exception even if there
3360      is no applicable Ada handler, and need at least one condition handler per
3361      possible call chain involving GNAT code.  OTOH, establishing the handler
3362      has a cost so we want to minimize the number of subprograms into which
3363      this happens.  The foreign or exported condition is expected to satisfy
3364      all the constraints.  */
3365   if (TARGET_ABI_OPEN_VMS
3366       && (Has_Foreign_Convention (gnat_subprog_id)
3367           || Is_Exported (gnat_subprog_id)))
3368     establish_gnat_vms_condition_handler ();
3369
3370   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3371
3372   /* Generate the code of the subprogram itself.  A return statement will be
3373      present and any Out parameters will be handled there.  */
3374   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3375   gnat_poplevel ();
3376   gnu_result = end_stmt_group ();
3377
3378   /* If we populated the parameter attributes cache, we need to make sure that
3379      the cached expressions are evaluated on all the possible paths leading to
3380      their uses.  So we force their evaluation on entry of the function.  */
3381   cache = gnu_subprog_language->parm_attr_cache;
3382   if (cache)
3383     {
3384       struct parm_attr_d *pa;
3385       int i;
3386
3387       start_stmt_group ();
3388
3389       FOR_EACH_VEC_ELT (parm_attr, cache, i, pa)
3390         {
3391           if (pa->first)
3392             add_stmt_with_node_force (pa->first, gnat_node);
3393           if (pa->last)
3394             add_stmt_with_node_force (pa->last, gnat_node);
3395           if (pa->length)
3396             add_stmt_with_node_force (pa->length, gnat_node);
3397         }
3398
3399       add_stmt (gnu_result);
3400       gnu_result = end_stmt_group ();
3401
3402       gnu_subprog_language->parm_attr_cache = NULL;
3403     }
3404
3405   /* If we are dealing with a return from an Ada procedure with parameters
3406      passed by copy-in/copy-out, we need to return a record containing the
3407      final values of these parameters.  If the list contains only one entry,
3408      return just that entry though.
3409
3410      For a full description of the copy-in/copy-out parameter mechanism, see
3411      the part of the gnat_to_gnu_entity routine dealing with the translation
3412      of subprograms.
3413
3414      We need to make a block that contains the definition of that label and
3415      the copying of the return value.  It first contains the function, then
3416      the label and copy statement.  */
3417   if (gnu_cico_list)
3418     {
3419       tree gnu_retval;
3420
3421       add_stmt (gnu_result);
3422       add_stmt (build1 (LABEL_EXPR, void_type_node,
3423                         VEC_last (tree, gnu_return_label_stack)));
3424
3425       if (list_length (gnu_cico_list) == 1)
3426         gnu_retval = TREE_VALUE (gnu_cico_list);
3427       else
3428         gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
3429                                                   gnu_cico_list);
3430
3431       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
3432                           End_Label (Handled_Statement_Sequence (gnat_node)));
3433       gnat_poplevel ();
3434       gnu_result = end_stmt_group ();
3435     }
3436
3437   VEC_pop (tree, gnu_return_label_stack);
3438
3439   /* Attempt setting the end_locus of our GCC body tree, typically a
3440      BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
3441      declaration tree.  */
3442   set_end_locus_from_node (gnu_result, gnat_node);
3443   set_end_locus_from_node (gnu_subprog_decl, gnat_node);
3444
3445   end_subprog_body (gnu_result);
3446
3447   /* Finally annotate the parameters and disconnect the trees for parameters
3448      that we have turned into variables since they are now unusable.  */
3449   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3450        Present (gnat_param);
3451        gnat_param = Next_Formal_With_Extras (gnat_param))
3452     {
3453       tree gnu_param = get_gnu_tree (gnat_param);
3454       bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
3455
3456       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
3457                        DECL_BY_REF_P (gnu_param),
3458                        !is_var_decl && DECL_BY_DOUBLE_REF_P (gnu_param));
3459
3460       if (is_var_decl)
3461         save_gnu_tree (gnat_param, NULL_TREE, false);
3462     }
3463
3464   /* Disconnect the variable created for the return value.  */
3465   if (gnu_return_var_elmt)
3466     TREE_VALUE (gnu_return_var_elmt) = void_type_node;
3467
3468   /* If the function returns an aggregate type and we have candidates for
3469      a Named Return Value, finalize the optimization.  */
3470   if (optimize && gnu_subprog_language->named_ret_val)
3471     {
3472       finalize_nrv (gnu_subprog_decl,
3473                     gnu_subprog_language->named_ret_val,
3474                     gnu_subprog_language->other_ret_val,
3475                     gnu_subprog_language->gnat_ret);
3476       gnu_subprog_language->named_ret_val = NULL;
3477       gnu_subprog_language->other_ret_val = NULL;
3478     }
3479
3480   rest_of_subprog_body_compilation (gnu_subprog_decl);
3481
3482   /* If there is a stub associated with the function, build it now.  */
3483   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
3484     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
3485
3486   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
3487 }
3488 \f
3489 /* Return true if GNAT_NODE requires atomic synchronization.  */
3490
3491 static bool
3492 atomic_sync_required_p (Node_Id gnat_node)
3493 {
3494   const Node_Id gnat_parent = Parent (gnat_node);
3495   Node_Kind kind;
3496   unsigned char attr_id;
3497
3498   /* First, scan the node to find the Atomic_Sync_Required flag.  */
3499   kind = Nkind (gnat_node);
3500   if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
3501     {
3502       gnat_node = Expression (gnat_node);
3503       kind = Nkind (gnat_node);
3504     }
3505
3506   switch (kind)
3507     {
3508     case N_Expanded_Name:
3509     case N_Explicit_Dereference:
3510     case N_Identifier:
3511     case N_Indexed_Component:
3512     case N_Selected_Component:
3513       if (!Atomic_Sync_Required (gnat_node))
3514         return false;
3515       break;
3516
3517     default:
3518       return false;
3519     }
3520
3521   /* Then, scan the parent to find out cases where the flag is irrelevant.  */
3522   kind = Nkind (gnat_parent);
3523   switch (kind)
3524     {
3525     case N_Attribute_Reference:
3526       attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
3527       /* Do not mess up machine code insertions.  */
3528       if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
3529         return false;
3530       break;
3531
3532     case N_Object_Renaming_Declaration:
3533       /* Do not generate a function call as a renamed object.  */
3534       return false;
3535
3536     default:
3537       break;
3538     }
3539
3540   return true;
3541 }
3542 \f
3543 /* Create a temporary variable with PREFIX and TYPE, and return it.  */
3544
3545 static tree
3546 create_temporary (const char *prefix, tree type)
3547 {
3548   tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
3549                                    type, NULL_TREE, false, false, false, false,
3550                                    NULL, Empty);
3551   DECL_ARTIFICIAL (gnu_temp) = 1;
3552   DECL_IGNORED_P (gnu_temp) = 1;
3553
3554   return gnu_temp;
3555 }
3556
3557 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
3558    Put the initialization statement into GNU_INIT_STMT and annotate it with
3559    the SLOC of GNAT_NODE.  Return the temporary variable.  */
3560
3561 static tree
3562 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
3563                        Node_Id gnat_node)
3564 {
3565   tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
3566
3567   *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
3568   set_expr_location_from_node (*gnu_init_stmt, gnat_node);
3569
3570   return gnu_temp;
3571 }
3572
3573 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
3574    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
3575    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
3576    If GNU_TARGET is non-null, this must be a function call on the RHS of a
3577    N_Assignment_Statement and the result is to be placed into that object.
3578    If, in addition, ATOMIC_SYNC is true, then the assignment to GNU_TARGET
3579    requires atomic synchronization.  */
3580
3581 static tree
3582 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
3583              bool atomic_sync)
3584 {
3585   const bool function_call = (Nkind (gnat_node) == N_Function_Call);
3586   const bool returning_value = (function_call && !gnu_target);
3587   /* The GCC node corresponding to the GNAT subprogram name.  This can either
3588      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
3589      or an indirect reference expression (an INDIRECT_REF node) pointing to a
3590      subprogram.  */
3591   tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
3592   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
3593   tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
3594   /* The return type of the FUNCTION_TYPE.  */
3595   tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
3596   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
3597   VEC(tree,gc) *gnu_actual_vec = NULL;
3598   tree gnu_name_list = NULL_TREE;
3599   tree gnu_stmt_list = NULL_TREE;
3600   tree gnu_after_list = NULL_TREE;
3601   tree gnu_retval = NULL_TREE;
3602   tree gnu_call, gnu_result;
3603   bool went_into_elab_proc = false;
3604   bool pushed_binding_level = false;
3605   Entity_Id gnat_formal;
3606   Node_Id gnat_actual;
3607
3608   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
3609
3610   /* If we are calling a stubbed function, raise Program_Error, but Elaborate
3611      all our args first.  */
3612   if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
3613     {
3614       tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
3615                                          gnat_node, N_Raise_Program_Error);
3616
3617       for (gnat_actual = First_Actual (gnat_node);
3618            Present (gnat_actual);
3619            gnat_actual = Next_Actual (gnat_actual))
3620         add_stmt (gnat_to_gnu (gnat_actual));
3621
3622       if (returning_value)
3623         {
3624           *gnu_result_type_p = gnu_result_type;
3625           return build1 (NULL_EXPR, gnu_result_type, call_expr);
3626         }
3627
3628       return call_expr;
3629     }
3630
3631   /* The only way we can be making a call via an access type is if Name is an
3632      explicit dereference.  In that case, get the list of formal args from the
3633      type the access type is pointing to.  Otherwise, get the formals from the
3634      entity being called.  */
3635   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3636     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
3637   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
3638     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
3639     gnat_formal = Empty;
3640   else
3641     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
3642
3643   /* The lifetime of the temporaries created for the call ends right after the
3644      return value is copied, so we can give them the scope of the elaboration
3645      routine at top level.  */
3646   if (!current_function_decl)
3647     {
3648       current_function_decl = get_elaboration_procedure ();
3649       went_into_elab_proc = true;
3650     }
3651
3652   /* First, create the temporary for the return value when:
3653
3654        1. There is no target and the function has copy-in/copy-out parameters,
3655           because we need to preserve the return value before copying back the
3656           parameters.
3657
3658        2. There is no target and this is not an object declaration, and the
3659           return type has variable size, because in these cases the gimplifier
3660           cannot create the temporary.
3661
3662        3. There is a target and it is a slice or an array with fixed size,
3663           and the return type has variable size, because the gimplifier
3664           doesn't handle these cases.
3665
3666      This must be done before we push a binding level around the call, since
3667      we will pop it before copying the return value.  */
3668   if (function_call
3669       && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
3670           || (!gnu_target
3671               && Nkind (Parent (gnat_node)) != N_Object_Declaration
3672               && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
3673           || (gnu_target
3674               && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
3675                   || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
3676                       && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
3677                          == INTEGER_CST))
3678               && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
3679     gnu_retval = create_temporary ("R", gnu_result_type);
3680
3681   /* Create the list of the actual parameters as GCC expects it, namely a
3682      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
3683      is an expression and the TREE_PURPOSE field is null.  But skip Out
3684      parameters not passed by reference and that need not be copied in.  */
3685   for (gnat_actual = First_Actual (gnat_node);
3686        Present (gnat_actual);
3687        gnat_formal = Next_Formal_With_Extras (gnat_formal),
3688        gnat_actual = Next_Actual (gnat_actual))
3689     {
3690       tree gnu_formal = present_gnu_tree (gnat_formal)
3691                         ? get_gnu_tree (gnat_formal) : NULL_TREE;
3692       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
3693       const bool is_true_formal_parm
3694         = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
3695       const bool is_by_ref_formal_parm
3696         = is_true_formal_parm
3697           && (DECL_BY_REF_P (gnu_formal)
3698               || DECL_BY_COMPONENT_PTR_P (gnu_formal)
3699               || DECL_BY_DESCRIPTOR_P (gnu_formal));
3700       /* In the Out or In Out case, we must suppress conversions that yield
3701          an&nbs