gcc/ada/gcc-interface/trans.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                T R A N S                                 *
   6  *                                                                          *
   7  *                          C Implementation File                           *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2012, Free Software Foundation, Inc.         *
  10  *                                                                          *
  11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  12  * terms of the  GNU General Public License as published  by the Free Soft- *
  13  * ware  Foundation;  either version 3,  or (at your option) any later ver- *
  14  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  15  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  16  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  17  * for  more details.  You should have  received  a copy of the GNU General *
  18  * Public License  distributed  with GNAT;  see file  COPYING3.  If not see *
  19  * <http://www.gnu.org/licenses/>.                                          *
  20  *                                                                          *
  21  * GNAT was originally developed  by the GNAT team at  New York University. *
  22  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  23  *                                                                          *
  24  ****************************************************************************/
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "tm.h"
  30 #include "tree.h"
  31 #include "flags.h"
  32 #include "ggc.h"
  33 #include "output.h"
  34 #include "libfuncs.h"   /* For set_stack_check_libfunc.  */
  35 #include "tree-iterator.h"
  36 #include "gimple.h"
  37 #include "bitmap.h"
  38 #include "cgraph.h"
  39
  40 #include "ada.h"
  41 #include "adadecode.h"
  42 #include "types.h"
  43 #include "atree.h"
  44 #include "elists.h"
  45 #include "namet.h"
  46 #include "nlists.h"
  47 #include "snames.h"
  48 #include "stringt.h"
  49 #include "uintp.h"
  50 #include "urealp.h"
  51 #include "fe.h"
  52 #include "sinfo.h"
  53 #include "einfo.h"
  54 #include "gadaint.h"
  55 #include "ada-tree.h"
  56 #include "gigi.h"
  57
  58 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
  59    for fear of running out of stack space.  If we need more, we use xmalloc
  60    instead.  */
  61 #define ALLOCA_THRESHOLD 1000
  62
  63 /* Let code below know whether we are targetting VMS without need of
  64    intrusive preprocessor directives.  */
  65 #ifndef TARGET_ABI_OPEN_VMS
  66 #define TARGET_ABI_OPEN_VMS 0
  67 #endif
  68
  69 /* In configurations where blocks have no end_locus attached, just
  70    sink assignments into a dummy global.  */
  71 #ifndef BLOCK_SOURCE_END_LOCATION
  72 static location_t block_end_locus_sink;
  73 #define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink
  74 #endif
  75
  76 /* For efficient float-to-int rounding, it is necessary to know whether
  77    floating-point arithmetic may use wider intermediate results.  When
  78    FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
  79    that arithmetic does not widen if double precision is emulated.  */
  80 #ifndef FP_ARITH_MAY_WIDEN
  81 #if defined(HAVE_extendsfdf2)
  82 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
  83 #else
  84 #define FP_ARITH_MAY_WIDEN 0
  85 #endif
  86 #endif
  87
  88 /* Pointers to front-end tables accessed through macros.  */
  89 struct Node *Nodes_Ptr;
  90 Node_Id *Next_Node_Ptr;
  91 Node_Id *Prev_Node_Ptr;
  92 struct Elist_Header *Elists_Ptr;
  93 struct Elmt_Item *Elmts_Ptr;
  94 struct String_Entry *Strings_Ptr;
  95 Char_Code *String_Chars_Ptr;
  96 struct List_Header *List_Headers_Ptr;
  97
  98 /* Highest number in the front-end node table.  */
  99 int max_gnat_nodes;
 100
 101 /* Current node being treated, in case abort called.  */
 102 Node_Id error_gnat_node;
 103
 104 /* True when gigi is being called on an analyzed but unexpanded
 105    tree, and the only purpose of the call is to properly annotate
 106    types with representation information.  */
 107 bool type_annotate_only;
 108
 109 /* Current filename without path.  */
 110 const char *ref_filename;
 111
 112 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
 113    of unconstrained array IN parameters to avoid emitting a great deal of
 114    redundant instructions to recompute them each time.  */
 115 struct GTY (()) parm_attr_d {
 116   int id; /* GTY doesn't like Entity_Id.  */
 117   int dim;
 118   tree first;
 119   tree last;
 120   tree length;
 121 };
 122
 123 typedef struct parm_attr_d *parm_attr;
 124
 125 DEF_VEC_P(parm_attr);
 126 DEF_VEC_ALLOC_P(parm_attr,gc);
 127
 128 struct GTY(()) language_function {
 129   VEC(parm_attr,gc) *parm_attr_cache;
 130   bitmap named_ret_val;
 131   VEC(tree,gc) *other_ret_val;
 132   int gnat_ret;
 133 };
 134
 135 #define f_parm_attr_cache \
 136   DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
 137
 138 #define f_named_ret_val \
 139   DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
 140
 141 #define f_other_ret_val \
 142   DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
 143
 144 #define f_gnat_ret \
 145   DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
 146
 147 /* A structure used to gather together information about a statement group.
 148    We use this to gather related statements, for example the "then" part
 149    of a IF.  In the case where it represents a lexical scope, we may also
 150    have a BLOCK node corresponding to it and/or cleanups.  */
 151
 152 struct GTY((chain_next ("%h.previous"))) stmt_group {
 153   struct stmt_group *previous;  /* Previous code group.  */
 154   tree stmt_list;               /* List of statements for this code group.  */
 155   tree block;                   /* BLOCK for this code group, if any.  */
 156   tree cleanups;                /* Cleanups for this code group, if any.  */
 157 };
 158
 159 static GTY(()) struct stmt_group *current_stmt_group;
 160
 161 /* List of unused struct stmt_group nodes.  */
 162 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
 163
 164 /* A structure used to record information on elaboration procedures
 165    we've made and need to process.
 166
 167    ??? gnat_node should be Node_Id, but gengtype gets confused.  */
 168
 169 struct GTY((chain_next ("%h.next"))) elab_info {
 170   struct elab_info *next;       /* Pointer to next in chain.  */
 171   tree elab_proc;               /* Elaboration procedure.  */
 172   int gnat_node;                /* The N_Compilation_Unit.  */
 173 };
 174
 175 static GTY(()) struct elab_info *elab_info_list;
 176
 177 /* Stack of exception pointer variables.  Each entry is the VAR_DECL
 178    that stores the address of the raised exception.  Nonzero means we
 179    are in an exception handler.  Not used in the zero-cost case.  */
 180 static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack;
 181
 182 /* In ZCX case, current exception pointer.  Used to re-raise it.  */
 183 static GTY(()) tree gnu_incoming_exc_ptr;
 184
 185 /* Stack for storing the current elaboration procedure decl.  */
 186 static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack;
 187
 188 /* Stack of labels to be used as a goto target instead of a return in
 189    some functions.  See processing for N_Subprogram_Body.  */
 190 static GTY(()) VEC(tree,gc) *gnu_return_label_stack;
 191
 192 /* Stack of variable for the return value of a function with copy-in/copy-out
 193    parameters.  See processing for N_Subprogram_Body.  */
 194 static GTY(()) VEC(tree,gc) *gnu_return_var_stack;
 195
 196 /* Structure used to record information for a range check.  */
 197 struct GTY(()) range_check_info_d {
 198   tree low_bound;
 199   tree high_bound;
 200   tree type;
 201   tree invariant_cond;
 202 };
 203
 204 typedef struct range_check_info_d *range_check_info;
 205
 206 DEF_VEC_P(range_check_info);
 207 DEF_VEC_ALLOC_P(range_check_info,gc);
 208
 209 /* Structure used to record information for a loop.  */
 210 struct GTY(()) loop_info_d {
 211   tree label;
 212   tree loop_var;
 213   VEC(range_check_info,gc) *checks;
 214 };
 215
 216 typedef struct loop_info_d *loop_info;
 217
 218 DEF_VEC_P(loop_info);
 219 DEF_VEC_ALLOC_P(loop_info,gc);
 220
 221 /* Stack of loop_info structures associated with LOOP_STMT nodes.  */
 222 static GTY(()) VEC(loop_info,gc) *gnu_loop_stack;
 223
 224 /* The stacks for N_{Push,Pop}_*_Label.  */
 225 static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack;
 226 static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack;
 227 static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack;
 228
 229 /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
 230 static enum tree_code gnu_codes[Number_Node_Kinds];
 231
 232 static void init_code_table (void);
 233 static void Compilation_Unit_to_gnu (Node_Id);
 234 static void record_code_position (Node_Id);
 235 static void insert_code_for (Node_Id);
 236 static void add_cleanup (tree, Node_Id);
 237 static void add_stmt_list (List_Id);
 238 static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id);
 239 static tree build_stmt_group (List_Id, bool);
 240 static enum gimplify_status gnat_gimplify_stmt (tree *);
 241 static void elaborate_all_entities (Node_Id);
 242 static void process_freeze_entity (Node_Id);
 243 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
 244 static tree emit_range_check (tree, Node_Id, Node_Id);
 245 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
 246 static tree emit_check (tree, tree, int, Node_Id);
 247 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
 248 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
 249 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
 250 static bool addressable_p (tree, tree);
 251 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 252 static tree extract_values (tree, tree);
 253 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
 254 static tree maybe_implicit_deref (tree);
 255 static void set_expr_location_from_node (tree, Node_Id);
 256 static bool set_end_locus_from_node (tree, Node_Id);
 257 static void set_gnu_expr_location_from_node (tree, Node_Id);
 258 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
 259 static tree build_raise_check (int, enum exception_info_kind);
 260 static tree create_init_temporary (const char *, tree, tree *, Node_Id);
 261
 262 /* Hooks for debug info back-ends, only supported and used in a restricted set
 263    of configurations.  */
 264 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
 265 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
 266 \f
 267 /* This is the main program of the back-end.  It sets up all the table
 268    structures and then generates code.  */
 269
 270 void
 271 gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
 272       struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
 273       struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
 274       struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
 275       struct List_Header *list_headers_ptr, Nat number_file,
 276       struct File_Info_Type *file_info_ptr,
 277       Entity_Id standard_boolean, Entity_Id standard_integer,
 278       Entity_Id standard_character, Entity_Id standard_long_long_float,
 279       Entity_Id standard_exception_type, Int gigi_operating_mode)
 280 {
 281   Entity_Id gnat_literal;
 282   tree long_long_float_type, exception_type, t, ftype;
 283   tree int64_type = gnat_type_for_size (64, 0);
 284   struct elab_info *info;
 285   int i;
 286
 287   max_gnat_nodes = max_gnat_node;
 288
 289   Nodes_Ptr = nodes_ptr;
 290   Next_Node_Ptr = next_node_ptr;
 291   Prev_Node_Ptr = prev_node_ptr;
 292   Elists_Ptr = elists_ptr;
 293   Elmts_Ptr = elmts_ptr;
 294   Strings_Ptr = strings_ptr;
 295   String_Chars_Ptr = string_chars_ptr;
 296   List_Headers_Ptr = list_headers_ptr;
 297
 298   type_annotate_only = (gigi_operating_mode == 1);
 299
 300   for (i = 0; i < number_file; i++)
 301     {
 302       /* Use the identifier table to make a permanent copy of the filename as
 303          the name table gets reallocated after Gigi returns but before all the
 304          debugging information is output.  The __gnat_to_canonical_file_spec
 305          call translates filenames from pragmas Source_Reference that contain
 306          host style syntax not understood by gdb.  */
 307       const char *filename
 308         = IDENTIFIER_POINTER
 309            (get_identifier
 310             (__gnat_to_canonical_file_spec
 311              (Get_Name_String (file_info_ptr[i].File_Name))));
 312
 313       /* We rely on the order isomorphism between files and line maps.  */
 314       gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i);
 315
 316       /* We create the line map for a source file at once, with a fixed number
 317          of columns chosen to avoid jumping over the next power of 2.  */
 318       linemap_add (line_table, LC_ENTER, 0, filename, 1);
 319       linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
 320       linemap_position_for_column (line_table, 252 - 1);
 321       linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
 322     }
 323
 324   gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
 325
 326   /* Declare the name of the compilation unit as the first global
 327      name in order to make the middle-end fully deterministic.  */
 328   t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
 329   first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
 330
 331   /* Initialize ourselves.  */
 332   init_code_table ();
 333   init_gnat_to_gnu ();
 334   init_dummy_type ();
 335
 336   /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
 337      errors.  */
 338   if (type_annotate_only)
 339     {
 340       TYPE_SIZE (void_type_node) = bitsize_zero_node;
 341       TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
 342     }
 343
 344   /* Enable GNAT stack checking method if needed */
 345   if (!Stack_Check_Probes_On_Target)
 346     set_stack_check_libfunc ("_gnat_stack_check");
 347
 348   /* Retrieve alignment settings.  */
 349   double_float_alignment = get_target_double_float_alignment ();
 350   double_scalar_alignment = get_target_double_scalar_alignment ();
 351
 352   /* Record the builtin types.  Define `integer' and `character' first so that
 353      dbx will output them first.  */
 354   record_builtin_type ("integer", integer_type_node, false);
 355   record_builtin_type ("character", unsigned_char_type_node, false);
 356   record_builtin_type ("boolean", boolean_type_node, false);
 357   record_builtin_type ("void", void_type_node, false);
 358
 359   /* Save the type we made for integer as the type for Standard.Integer.  */
 360   save_gnu_tree (Base_Type (standard_integer),
 361                  TYPE_NAME (integer_type_node),
 362                  false);
 363
 364   /* Likewise for character as the type for Standard.Character.  */
 365   save_gnu_tree (Base_Type (standard_character),
 366                  TYPE_NAME (unsigned_char_type_node),
 367                  false);
 368
 369   /* Likewise for boolean as the type for Standard.Boolean.  */
 370   save_gnu_tree (Base_Type (standard_boolean),
 371                  TYPE_NAME (boolean_type_node),
 372                  false);
 373   gnat_literal = First_Literal (Base_Type (standard_boolean));
 374   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 375   gcc_assert (t == boolean_false_node);
 376   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 377                        boolean_type_node, t, true, false, false, false,
 378                        NULL, gnat_literal);
 379   DECL_IGNORED_P (t) = 1;
 380   save_gnu_tree (gnat_literal, t, false);
 381   gnat_literal = Next_Literal (gnat_literal);
 382   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 383   gcc_assert (t == boolean_true_node);
 384   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 385                        boolean_type_node, t, true, false, false, false,
 386                        NULL, gnat_literal);
 387   DECL_IGNORED_P (t) = 1;
 388   save_gnu_tree (gnat_literal, t, false);
 389
 390   void_ftype = build_function_type_list (void_type_node, NULL_TREE);
 391   ptr_void_ftype = build_pointer_type (void_ftype);
 392
 393   /* Now declare run-time functions.  */
 394   ftype = build_function_type_list (ptr_void_type_node, sizetype, NULL_TREE);
 395
 396   /* malloc is a function declaration tree for a function to allocate
 397      memory.  */
 398   malloc_decl
 399     = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
 400                            ftype, NULL_TREE, false, true, true, true, NULL,
 401                            Empty);
 402   DECL_IS_MALLOC (malloc_decl) = 1;
 403
 404   /* malloc32 is a function declaration tree for a function to allocate
 405      32-bit memory on a 64-bit system.  Needed only on 64-bit VMS.  */
 406   malloc32_decl
 407     = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
 408                            ftype, NULL_TREE, false, true, true, true, NULL,
 409                            Empty);
 410   DECL_IS_MALLOC (malloc32_decl) = 1;
 411
 412   /* free is a function declaration tree for a function to free memory.  */
 413   free_decl
 414     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
 415                            build_function_type_list (void_type_node,
 416                                                      ptr_void_type_node,
 417                                                      NULL_TREE),
 418                            NULL_TREE, false, true, true, true, NULL, Empty);
 419
 420   /* This is used for 64-bit multiplication with overflow checking.  */
 421   mulv64_decl
 422     = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
 423                            build_function_type_list (int64_type, int64_type,
 424                                                      int64_type, NULL_TREE),
 425                            NULL_TREE, false, true, true, true, NULL, Empty);
 426
 427   /* Name of the _Parent field in tagged record types.  */
 428   parent_name_id = get_identifier (Get_Name_String (Name_uParent));
 429
 430   /* Name of the Exception_Data type defined in System.Standard_Library.  */
 431   exception_data_name_id
 432     = get_identifier ("system__standard_library__exception_data");
 433
 434   /* Make the types and functions used for exception processing.  */
 435   jmpbuf_type
 436     = build_array_type (gnat_type_for_mode (Pmode, 0),
 437                         build_index_type (size_int (5)));
 438   record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
 439   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
 440
 441   /* Functions to get and set the jumpbuf pointer for the current thread.  */
 442   get_jmpbuf_decl
 443     = create_subprog_decl
 444       (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
 445        NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
 446        NULL_TREE, false, true, true, true, NULL, Empty);
 447   DECL_IGNORED_P (get_jmpbuf_decl) = 1;
 448
 449   set_jmpbuf_decl
 450     = create_subprog_decl
 451       (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
 452        NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
 453                                             NULL_TREE),
 454        NULL_TREE, false, true, true, true, NULL, Empty);
 455   DECL_IGNORED_P (set_jmpbuf_decl) = 1;
 456
 457   /* setjmp returns an integer and has one operand, which is a pointer to
 458      a jmpbuf.  */
 459   setjmp_decl
 460     = create_subprog_decl
 461       (get_identifier ("__builtin_setjmp"), NULL_TREE,
 462        build_function_type_list (integer_type_node, jmpbuf_ptr_type,
 463                                  NULL_TREE),
 464        NULL_TREE, false, true, true, true, NULL, Empty);
 465   DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
 466   DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
 467
 468   /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
 469      address.  */
 470   update_setjmp_buf_decl
 471     = create_subprog_decl
 472       (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
 473        build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
 474        NULL_TREE, false, true, true, true, NULL, Empty);
 475   DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
 476   DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
 477
 478   /* Hooks to call when entering/leaving an exception handler.  */
 479   ftype
 480     = build_function_type_list (void_type_node, ptr_void_type_node, NULL_TREE);
 481
 482   begin_handler_decl
 483     = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
 484                            ftype, NULL_TREE, false, true, true, true, NULL,
 485                            Empty);
 486   DECL_IGNORED_P (begin_handler_decl) = 1;
 487
 488   end_handler_decl
 489     = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
 490                            ftype, NULL_TREE, false, true, true, true, NULL,
 491                            Empty);
 492   DECL_IGNORED_P (end_handler_decl) = 1;
 493
 494   reraise_zcx_decl
 495     = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
 496                            ftype, NULL_TREE, false, true, true, true, NULL,
 497                            Empty);
 498   DECL_IGNORED_P (reraise_zcx_decl) = 1;
 499
 500   /* If in no exception handlers mode, all raise statements are redirected to
 501      __gnat_last_chance_handler.  No need to redefine raise_nodefer_decl since
 502      this procedure will never be called in this mode.  */
 503   if (No_Exception_Handlers_Set ())
 504     {
 505       tree decl
 506         = create_subprog_decl
 507           (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
 508            build_function_type_list (void_type_node,
 509                                      build_pointer_type
 510                                      (unsigned_char_type_node),
 511                                      integer_type_node, NULL_TREE),
 512            NULL_TREE, false, true, true, true, NULL, Empty);
 513       TREE_THIS_VOLATILE (decl) = 1;
 514       TREE_SIDE_EFFECTS (decl) = 1;
 515       TREE_TYPE (decl)
 516         = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
 517       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 518         gnat_raise_decls[i] = decl;
 519     }
 520   else
 521     {
 522       /* Otherwise, make one decl for each exception reason.  */
 523       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 524         gnat_raise_decls[i] = build_raise_check (i, exception_simple);
 525       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
 526         gnat_raise_decls_ext[i]
 527           = build_raise_check (i,
 528                                i == CE_Index_Check_Failed
 529                                || i == CE_Range_Check_Failed
 530                                || i == CE_Invalid_Data
 531                                ? exception_range : exception_column);
 532     }
 533
 534   /* Set the types that GCC and Gigi use from the front end.  */
 535   exception_type
 536     = gnat_to_gnu_entity (Base_Type (standard_exception_type),  NULL_TREE, 0);
 537   except_type_node = TREE_TYPE (exception_type);
 538
 539   /* Make other functions used for exception processing.  */
 540   get_excptr_decl
 541     = create_subprog_decl
 542       (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
 543        build_function_type_list (build_pointer_type (except_type_node),
 544                                  NULL_TREE),
 545      NULL_TREE, false, true, true, true, NULL, Empty);
 546
 547   raise_nodefer_decl
 548     = create_subprog_decl
 549       (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
 550        build_function_type_list (void_type_node,
 551                                  build_pointer_type (except_type_node),
 552                                  NULL_TREE),
 553        NULL_TREE, false, true, true, true, NULL, Empty);
 554
 555   /* Indicate that it never returns.  */
 556   TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
 557   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
 558   TREE_TYPE (raise_nodefer_decl)
 559     = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
 560                             TYPE_QUAL_VOLATILE);
 561
 562   /* Build the special descriptor type and its null node if needed.  */
 563   if (TARGET_VTABLE_USES_DESCRIPTORS)
 564     {
 565       tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
 566       tree field_list = NULL_TREE;
 567       int j;
 568       VEC(constructor_elt,gc) *null_vec = NULL;
 569       constructor_elt *elt;
 570
 571       fdesc_type_node = make_node (RECORD_TYPE);
 572       VEC_safe_grow (constructor_elt, gc, null_vec,
 573                      TARGET_VTABLE_USES_DESCRIPTORS);
 574       elt = (VEC_address (constructor_elt,null_vec)
 575              + TARGET_VTABLE_USES_DESCRIPTORS - 1);
 576
 577       for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
 578         {
 579           tree field
 580             = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
 581                                  NULL_TREE, NULL_TREE, 0, 1);
 582           DECL_CHAIN (field) = field_list;
 583           field_list = field;
 584           elt->index = field;
 585           elt->value = null_node;
 586           elt--;
 587         }
 588
 589       finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
 590       record_builtin_type ("descriptor", fdesc_type_node, true);
 591       null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
 592     }
 593
 594   long_long_float_type
 595     = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
 596
 597   if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
 598     {
 599       /* In this case, the builtin floating point types are VAX float,
 600          so make up a type for use.  */
 601       longest_float_type_node = make_node (REAL_TYPE);
 602       TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
 603       layout_type (longest_float_type_node);
 604       record_builtin_type ("longest float type", longest_float_type_node,
 605                            false);
 606     }
 607   else
 608     longest_float_type_node = TREE_TYPE (long_long_float_type);
 609
 610   /* Dummy objects to materialize "others" and "all others" in the exception
 611      tables.  These are exported by a-exexpr-gcc.adb, so see this unit for
 612      the types to use.  */
 613   others_decl
 614     = create_var_decl (get_identifier ("OTHERS"),
 615                        get_identifier ("__gnat_others_value"),
 616                        integer_type_node, NULL_TREE, true, false, true, false,
 617                        NULL, Empty);
 618
 619   all_others_decl
 620     = create_var_decl (get_identifier ("ALL_OTHERS"),
 621                        get_identifier ("__gnat_all_others_value"),
 622                        integer_type_node, NULL_TREE, true, false, true, false,
 623                        NULL, Empty);
 624
 625   main_identifier_node = get_identifier ("main");
 626
 627   /* Install the builtins we might need, either internally or as
 628      user available facilities for Intrinsic imports.  */
 629   gnat_install_builtins ();
 630
 631   VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE);
 632   VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE);
 633   VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE);
 634   VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE);
 635
 636   /* Process any Pragma Ident for the main unit.  */
 637 #ifdef ASM_OUTPUT_IDENT
 638   if (Present (Ident_String (Main_Unit)))
 639     ASM_OUTPUT_IDENT
 640       (asm_out_file,
 641        TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
 642 #endif
 643
 644   /* If we are using the GCC exception mechanism, let GCC know.  */
 645   if (Exception_Mechanism == Back_End_Exceptions)
 646     gnat_init_gcc_eh ();
 647
 648   /* Now translate the compilation unit proper.  */
 649   Compilation_Unit_to_gnu (gnat_root);
 650
 651   /* Finally see if we have any elaboration procedures to deal with.  */
 652   for (info = elab_info_list; info; info = info->next)
 653     {
 654       tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
 655
 656       /* We should have a BIND_EXPR but it may not have any statements in it.
 657          If it doesn't have any, we have nothing to do except for setting the
 658          flag on the GNAT node.  Otherwise, process the function as others.  */
 659       gnu_stmts = gnu_body;
 660       if (TREE_CODE (gnu_stmts) == BIND_EXPR)
 661         gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
 662       if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
 663         Set_Has_No_Elaboration_Code (info->gnat_node, 1);
 664       else
 665         {
 666           begin_subprog_body (info->elab_proc);
 667           end_subprog_body (gnu_body);
 668           rest_of_subprog_body_compilation (info->elab_proc);
 669         }
 670     }
 671
 672   /* We cannot track the location of errors past this point.  */
 673   error_gnat_node = Empty;
 674 }
 675 \f
 676 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
 677    CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext.  */
 678
 679 static tree
 680 build_raise_check (int check, enum exception_info_kind kind)
 681 {
 682   char name[21];
 683   tree result, ftype;
 684
 685   if (kind == exception_simple)
 686     {
 687       sprintf (name, "__gnat_rcheck_%.2d", check);
 688       ftype
 689         = build_function_type_list (void_type_node,
 690                                     build_pointer_type
 691                                     (unsigned_char_type_node),
 692                                     integer_type_node, NULL_TREE);
 693     }
 694   else
 695     {
 696       tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
 697       sprintf (name, "__gnat_rcheck_%.2d_ext", check);
 698       ftype
 699         = build_function_type_list (void_type_node,
 700                                     build_pointer_type
 701                                     (unsigned_char_type_node),
 702                                     integer_type_node, integer_type_node,
 703                                     t, t, NULL_TREE);
 704     }
 705
 706   result
 707     = create_subprog_decl (get_identifier (name), NULL_TREE, ftype, NULL_TREE,
 708                            false, true, true, true, NULL, Empty);
 709
 710   /* Indicate that it never returns.  */
 711   TREE_THIS_VOLATILE (result) = 1;
 712   TREE_SIDE_EFFECTS (result) = 1;
 713   TREE_TYPE (result)
 714     = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE);
 715
 716   return result;
 717 }
 718 \f
 719 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
 720    an N_Attribute_Reference.  */
 721
 722 static int
 723 lvalue_required_for_attribute_p (Node_Id gnat_node)
 724 {
 725   switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
 726     {
 727     case Attr_Pos:
 728     case Attr_Val:
 729     case Attr_Pred:
 730     case Attr_Succ:
 731     case Attr_First:
 732     case Attr_Last:
 733     case Attr_Range_Length:
 734     case Attr_Length:
 735     case Attr_Object_Size:
 736     case Attr_Value_Size:
 737     case Attr_Component_Size:
 738     case Attr_Max_Size_In_Storage_Elements:
 739     case Attr_Min:
 740     case Attr_Max:
 741     case Attr_Null_Parameter:
 742     case Attr_Passed_By_Reference:
 743     case Attr_Mechanism_Code:
 744       return 0;
 745
 746     case Attr_Address:
 747     case Attr_Access:
 748     case Attr_Unchecked_Access:
 749     case Attr_Unrestricted_Access:
 750     case Attr_Code_Address:
 751     case Attr_Pool_Address:
 752     case Attr_Size:
 753     case Attr_Alignment:
 754     case Attr_Bit_Position:
 755     case Attr_Position:
 756     case Attr_First_Bit:
 757     case Attr_Last_Bit:
 758     case Attr_Bit:
 759     case Attr_Asm_Input:
 760     case Attr_Asm_Output:
 761     default:
 762       return 1;
 763     }
 764 }
 765
 766 /* Return a positive value if an lvalue is required for GNAT_NODE.  GNU_TYPE
 767    is the type that will be used for GNAT_NODE in the translated GNU tree.
 768    CONSTANT indicates whether the underlying object represented by GNAT_NODE
 769    is constant in the Ada sense.  If it is, ADDRESS_OF_CONSTANT indicates
 770    whether its value is the address of a constant and ALIASED whether it is
 771    aliased.  If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
 772
 773    The function climbs up the GNAT tree starting from the node and returns 1
 774    upon encountering a node that effectively requires an lvalue downstream.
 775    It returns int instead of bool to facilitate usage in non-purely binary
 776    logic contexts.  */
 777
 778 static int
 779 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
 780                    bool address_of_constant, bool aliased)
 781 {
 782   Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
 783
 784   switch (Nkind (gnat_parent))
 785     {
 786     case N_Reference:
 787       return 1;
 788
 789     case N_Attribute_Reference:
 790       return lvalue_required_for_attribute_p (gnat_parent);
 791
 792     case N_Parameter_Association:
 793     case N_Function_Call:
 794     case N_Procedure_Call_Statement:
 795       /* If the parameter is by reference, an lvalue is required.  */
 796       return (!constant
 797               || must_pass_by_ref (gnu_type)
 798               || default_pass_by_ref (gnu_type));
 799
 800     case N_Indexed_Component:
 801       /* Only the array expression can require an lvalue.  */
 802       if (Prefix (gnat_parent) != gnat_node)
 803         return 0;
 804
 805       /* ??? Consider that referencing an indexed component with a
 806          non-constant index forces the whole aggregate to memory.
 807          Note that N_Integer_Literal is conservative, any static
 808          expression in the RM sense could probably be accepted.  */
 809       for (gnat_temp = First (Expressions (gnat_parent));
 810            Present (gnat_temp);
 811            gnat_temp = Next (gnat_temp))
 812         if (Nkind (gnat_temp) != N_Integer_Literal)
 813           return 1;
 814
 815       /* ... fall through ... */
 816
 817     case N_Slice:
 818       /* Only the array expression can require an lvalue.  */
 819       if (Prefix (gnat_parent) != gnat_node)
 820         return 0;
 821
 822       aliased |= Has_Aliased_Components (Etype (gnat_node));
 823       return lvalue_required_p (gnat_parent, gnu_type, constant,
 824                                 address_of_constant, aliased);
 825
 826     case N_Selected_Component:
 827       aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
 828       return lvalue_required_p (gnat_parent, gnu_type, constant,
 829                                 address_of_constant, aliased);
 830
 831     case N_Object_Renaming_Declaration:
 832       /* We need to make a real renaming only if the constant object is
 833          aliased or if we may use a renaming pointer; otherwise we can
 834          optimize and return the rvalue.  We make an exception if the object
 835          is an identifier since in this case the rvalue can be propagated
 836          attached to the CONST_DECL.  */
 837       return (!constant
 838               || aliased
 839               /* This should match the constant case of the renaming code.  */
 840               || Is_Composite_Type
 841                  (Underlying_Type (Etype (Name (gnat_parent))))
 842               || Nkind (Name (gnat_parent)) == N_Identifier);
 843
 844     case N_Object_Declaration:
 845       /* We cannot use a constructor if this is an atomic object because
 846          the actual assignment might end up being done component-wise.  */
 847       return (!constant
 848               ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 849                  && Is_Atomic (Defining_Entity (gnat_parent)))
 850               /* We don't use a constructor if this is a class-wide object
 851                  because the effective type of the object is the equivalent
 852                  type of the class-wide subtype and it smashes most of the
 853                  data into an array of bytes to which we cannot convert.  */
 854               || Ekind ((Etype (Defining_Entity (gnat_parent))))
 855                  == E_Class_Wide_Subtype);
 856
 857     case N_Assignment_Statement:
 858       /* We cannot use a constructor if the LHS is an atomic object because
 859          the actual assignment might end up being done component-wise.  */
 860       return (!constant
 861               || Name (gnat_parent) == gnat_node
 862               || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 863                   && Is_Atomic (Entity (Name (gnat_parent)))));
 864
 865     case N_Unchecked_Type_Conversion:
 866         if (!constant)
 867           return 1;
 868
 869       /* ... fall through ... */
 870
 871     case N_Type_Conversion:
 872     case N_Qualified_Expression:
 873       /* We must look through all conversions because we may need to bypass
 874          an intermediate conversion that is meant to be purely formal.  */
 875      return lvalue_required_p (gnat_parent,
 876                                get_unpadded_type (Etype (gnat_parent)),
 877                                constant, address_of_constant, aliased);
 878
 879     case N_Allocator:
 880       /* We should only reach here through the N_Qualified_Expression case.
 881          Force an lvalue for composite types since a block-copy to the newly
 882          allocated area of memory is made.  */
 883       return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
 884
 885    case N_Explicit_Dereference:
 886       /* We look through dereferences for address of constant because we need
 887          to handle the special cases listed above.  */
 888       if (constant && address_of_constant)
 889         return lvalue_required_p (gnat_parent,
 890                                   get_unpadded_type (Etype (gnat_parent)),
 891                                   true, false, true);
 892
 893       /* ... fall through ... */
 894
 895     default:
 896       return 0;
 897     }
 898
 899   gcc_unreachable ();
 900 }
 901
 902 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
 903    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer
 904    to where we should place the result type.  */
 905
 906 static tree
 907 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 908 {
 909   Node_Id gnat_temp, gnat_temp_type;
 910   tree gnu_result, gnu_result_type;
 911
 912   /* Whether we should require an lvalue for GNAT_NODE.  Needed in
 913      specific circumstances only, so evaluated lazily.  < 0 means
 914      unknown, > 0 means known true, 0 means known false.  */
 915   int require_lvalue = -1;
 916
 917   /* If GNAT_NODE is a constant, whether we should use the initialization
 918      value instead of the constant entity, typically for scalars with an
 919      address clause when the parent doesn't require an lvalue.  */
 920   bool use_constant_initializer = false;
 921
 922   /* If the Etype of this node does not equal the Etype of the Entity,
 923      something is wrong with the entity map, probably in generic
 924      instantiation. However, this does not apply to types. Since we sometime
 925      have strange Ekind's, just do this test for objects. Also, if the Etype of
 926      the Entity is private, the Etype of the N_Identifier is allowed to be the
 927      full type and also we consider a packed array type to be the same as the
 928      original type. Similarly, a class-wide type is equivalent to a subtype of
 929      itself. Finally, if the types are Itypes, one may be a copy of the other,
 930      which is also legal.  */
 931   gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
 932                ? gnat_node : Entity (gnat_node));
 933   gnat_temp_type = Etype (gnat_temp);
 934
 935   gcc_assert (Etype (gnat_node) == gnat_temp_type
 936               || (Is_Packed (gnat_temp_type)
 937                   && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
 938               || (Is_Class_Wide_Type (Etype (gnat_node)))
 939               || (IN (Ekind (gnat_temp_type), Private_Kind)
 940                   && Present (Full_View (gnat_temp_type))
 941                   && ((Etype (gnat_node) == Full_View (gnat_temp_type))
 942                       || (Is_Packed (Full_View (gnat_temp_type))
 943                           && (Etype (gnat_node)
 944                               == Packed_Array_Type (Full_View
 945                                                     (gnat_temp_type))))))
 946               || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
 947               || !(Ekind (gnat_temp) == E_Variable
 948                    || Ekind (gnat_temp) == E_Component
 949                    || Ekind (gnat_temp) == E_Constant
 950                    || Ekind (gnat_temp) == E_Loop_Parameter
 951                    || IN (Ekind (gnat_temp), Formal_Kind)));
 952
 953   /* If this is a reference to a deferred constant whose partial view is an
 954      unconstrained private type, the proper type is on the full view of the
 955      constant, not on the full view of the type, which may be unconstrained.
 956
 957      This may be a reference to a type, for example in the prefix of the
 958      attribute Position, generated for dispatching code (see Make_DT in
 959      exp_disp,adb). In that case we need the type itself, not is parent,
 960      in particular if it is a derived type  */
 961   if (Ekind (gnat_temp) == E_Constant
 962       && Is_Private_Type (gnat_temp_type)
 963       && (Has_Unknown_Discriminants (gnat_temp_type)
 964           || (Present (Full_View (gnat_temp_type))
 965               && Has_Discriminants (Full_View (gnat_temp_type))))
 966       && Present (Full_View (gnat_temp)))
 967     {
 968       gnat_temp = Full_View (gnat_temp);
 969       gnat_temp_type = Etype (gnat_temp);
 970     }
 971   else
 972     {
 973       /* We want to use the Actual_Subtype if it has already been elaborated,
 974          otherwise the Etype.  Avoid using Actual_Subtype for packed arrays to
 975          simplify things.  */
 976       if ((Ekind (gnat_temp) == E_Constant
 977            || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
 978           && !(Is_Array_Type (Etype (gnat_temp))
 979                && Present (Packed_Array_Type (Etype (gnat_temp))))
 980           && Present (Actual_Subtype (gnat_temp))
 981           && present_gnu_tree (Actual_Subtype (gnat_temp)))
 982         gnat_temp_type = Actual_Subtype (gnat_temp);
 983       else
 984         gnat_temp_type = Etype (gnat_node);
 985     }
 986
 987   /* Expand the type of this identifier first, in case it is an enumeral
 988      literal, which only get made when the type is expanded.  There is no
 989      order-of-elaboration issue here.  */
 990   gnu_result_type = get_unpadded_type (gnat_temp_type);
 991
 992   /* If this is a non-imported scalar constant with an address clause,
 993      retrieve the value instead of a pointer to be dereferenced unless
 994      an lvalue is required.  This is generally more efficient and actually
 995      required if this is a static expression because it might be used
 996      in a context where a dereference is inappropriate, such as a case
 997      statement alternative or a record discriminant.  There is no possible
 998      volatile-ness short-circuit here since Volatile constants must be
 999      imported per C.6.  */
1000   if (Ekind (gnat_temp) == E_Constant
1001       && Is_Scalar_Type (gnat_temp_type)
1002       && !Is_Imported (gnat_temp)
1003       && Present (Address_Clause (gnat_temp)))
1004     {
1005       require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
1006                                           false, Is_Aliased (gnat_temp));
1007       use_constant_initializer = !require_lvalue;
1008     }
1009
1010   if (use_constant_initializer)
1011     {
1012       /* If this is a deferred constant, the initializer is attached to
1013          the full view.  */
1014       if (Present (Full_View (gnat_temp)))
1015         gnat_temp = Full_View (gnat_temp);
1016
1017       gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
1018     }
1019   else
1020     gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
1021
1022   /* Some objects (such as parameters passed by reference, globals of
1023      variable size, and renamed objects) actually represent the address
1024      of the object.  In that case, we must do the dereference.  Likewise,
1025      deal with parameters to foreign convention subprograms.  */
1026   if (DECL_P (gnu_result)
1027       && (DECL_BY_REF_P (gnu_result)
1028           || (TREE_CODE (gnu_result) == PARM_DECL
1029               && DECL_BY_COMPONENT_PTR_P (gnu_result))))
1030     {
1031       const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1032
1033       /* First do the first dereference if needed.  */
1034       if (TREE_CODE (gnu_result) == PARM_DECL
1035           && DECL_BY_DOUBLE_REF_P (gnu_result))
1036         {
1037           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1038           if (TREE_CODE (gnu_result) == INDIRECT_REF)
1039             TREE_THIS_NOTRAP (gnu_result) = 1;
1040
1041           /* The first reference, in case of a double reference, always points
1042              to read-only, see gnat_to_gnu_param for the rationale.  */
1043           TREE_READONLY (gnu_result) = 1;
1044         }
1045
1046       /* If it's a PARM_DECL to foreign convention subprogram, convert it.  */
1047       if (TREE_CODE (gnu_result) == PARM_DECL
1048           && DECL_BY_COMPONENT_PTR_P (gnu_result))
1049         gnu_result
1050           = convert (build_pointer_type (gnu_result_type), gnu_result);
1051
1052       /* If it's a CONST_DECL, return the underlying constant like below.  */
1053       else if (TREE_CODE (gnu_result) == CONST_DECL)
1054         gnu_result = DECL_INITIAL (gnu_result);
1055
1056       /* If it's a renaming pointer and we are at the right binding level,
1057          we can reference the renamed object directly, since the renamed
1058          expression has been protected against multiple evaluations.  */
1059       if (TREE_CODE (gnu_result) == VAR_DECL
1060           && !DECL_LOOP_PARM_P (gnu_result)
1061           && DECL_RENAMED_OBJECT (gnu_result)
1062           && (!DECL_RENAMING_GLOBAL_P (gnu_result) || global_bindings_p ()))
1063         gnu_result = DECL_RENAMED_OBJECT (gnu_result);
1064
1065       /* Otherwise, do the final dereference.  */
1066       else
1067         {
1068           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1069
1070           if ((TREE_CODE (gnu_result) == INDIRECT_REF
1071                || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
1072               && No (Address_Clause (gnat_temp)))
1073             TREE_THIS_NOTRAP (gnu_result) = 1;
1074
1075           if (read_only)
1076             TREE_READONLY (gnu_result) = 1;
1077         }
1078     }
1079
1080   /* If we have a constant declaration and its initializer, try to return the
1081      latter to avoid the need to call fold in lots of places and the need for
1082      elaboration code if this identifier is used as an initializer itself.
1083      Don't do it for aggregate types that contain a placeholder since their
1084      initializers cannot be manipulated easily.  */
1085   if (TREE_CONSTANT (gnu_result)
1086       && DECL_P (gnu_result)
1087       && DECL_INITIAL (gnu_result)
1088       && !(AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
1089            && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_result))
1090            && type_contains_placeholder_p (TREE_TYPE (gnu_result))))
1091     {
1092       bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1093                             && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1094       bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1095                                   && DECL_CONST_ADDRESS_P (gnu_result));
1096
1097       /* If there is a (corresponding) variable or this is the address of a
1098          constant, we only want to return the initializer if an lvalue isn't
1099          required.  Evaluate this now if we have not already done so.  */
1100       if ((!constant_only || address_of_constant) && require_lvalue < 0)
1101         require_lvalue
1102           = lvalue_required_p (gnat_node, gnu_result_type, true,
1103                                address_of_constant, Is_Aliased (gnat_temp));
1104
1105       /* ??? We need to unshare the initializer if the object is external
1106          as such objects are not marked for unsharing if we are not at the
1107          global level.  This should be fixed in add_decl_expr.  */
1108       if ((constant_only && !address_of_constant) || !require_lvalue)
1109         gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
1110     }
1111
1112   /* The GNAT tree has the type of a function set to its result type, so we
1113      adjust here.  Also use the type of the result if the Etype is a subtype
1114      that is nominally unconstrained.  Likewise if this is a deferred constant
1115      of a discriminated type whose full view can be elaborated statically, to
1116      avoid problematic conversions to the nominal subtype.  But remove any
1117      padding from the resulting type.  */
1118   if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1119       || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)
1120       || (Ekind (gnat_temp) == E_Constant
1121           && Present (Full_View (gnat_temp))
1122           && Has_Discriminants (gnat_temp_type)
1123           && TREE_CODE (gnu_result) == CONSTRUCTOR))
1124     {
1125       gnu_result_type = TREE_TYPE (gnu_result);
1126       if (TYPE_IS_PADDING_P (gnu_result_type))
1127         gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1128     }
1129
1130   *gnu_result_type_p = gnu_result_type;
1131
1132   return gnu_result;
1133 }
1134 \f
1135 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
1136    any statements we generate.  */
1137
1138 static tree
1139 Pragma_to_gnu (Node_Id gnat_node)
1140 {
1141   Node_Id gnat_temp;
1142   tree gnu_result = alloc_stmt_list ();
1143
1144   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1145      annotating types.  */
1146   if (type_annotate_only
1147       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1148     return gnu_result;
1149
1150   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1151     {
1152     case Pragma_Inspection_Point:
1153       /* Do nothing at top level: all such variables are already viewable.  */
1154       if (global_bindings_p ())
1155         break;
1156
1157       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1158            Present (gnat_temp);
1159            gnat_temp = Next (gnat_temp))
1160         {
1161           Node_Id gnat_expr = Expression (gnat_temp);
1162           tree gnu_expr = gnat_to_gnu (gnat_expr);
1163           int use_address;
1164           enum machine_mode mode;
1165           tree asm_constraint = NULL_TREE;
1166 #ifdef ASM_COMMENT_START
1167           char *comment;
1168 #endif
1169
1170           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1171             gnu_expr = TREE_OPERAND (gnu_expr, 0);
1172
1173           /* Use the value only if it fits into a normal register,
1174              otherwise use the address.  */
1175           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1176           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1177                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1178                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1179
1180           if (use_address)
1181             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1182
1183 #ifdef ASM_COMMENT_START
1184           comment = concat (ASM_COMMENT_START,
1185                             " inspection point: ",
1186                             Get_Name_String (Chars (gnat_expr)),
1187                             use_address ? " address" : "",
1188                             " is in %0",
1189                             NULL);
1190           asm_constraint = build_string (strlen (comment), comment);
1191           free (comment);
1192 #endif
1193           gnu_expr = build5 (ASM_EXPR, void_type_node,
1194                              asm_constraint,
1195                              NULL_TREE,
1196                              tree_cons
1197                              (build_tree_list (NULL_TREE,
1198                                                build_string (1, "g")),
1199                               gnu_expr, NULL_TREE),
1200                              NULL_TREE, NULL_TREE);
1201           ASM_VOLATILE_P (gnu_expr) = 1;
1202           set_expr_location_from_node (gnu_expr, gnat_node);
1203           append_to_statement_list (gnu_expr, &gnu_result);
1204         }
1205       break;
1206
1207     case Pragma_Optimize:
1208       switch (Chars (Expression
1209                      (First (Pragma_Argument_Associations (gnat_node)))))
1210         {
1211         case Name_Time:  case Name_Space:
1212           if (!optimize)
1213             post_error ("insufficient -O value?", gnat_node);
1214           break;
1215
1216         case Name_Off:
1217           if (optimize)
1218             post_error ("must specify -O0?", gnat_node);
1219           break;
1220
1221         default:
1222           gcc_unreachable ();
1223         }
1224       break;
1225
1226     case Pragma_Reviewable:
1227       if (write_symbols == NO_DEBUG)
1228         post_error ("must specify -g?", gnat_node);
1229       break;
1230     }
1231
1232   return gnu_result;
1233 }
1234 \f
1235 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1236    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
1237    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
1238
1239 static tree
1240 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1241 {
1242   tree gnu_prefix, gnu_type, gnu_expr;
1243   tree gnu_result_type, gnu_result = error_mark_node;
1244   bool prefix_unused = false;
1245
1246   /* ??? If this is an access attribute for a public subprogram to be used in
1247      a dispatch table, do not translate its type as it's useless there and the
1248      parameter types might be incomplete types coming from a limited with.  */
1249   if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
1250       && Is_Dispatch_Table_Entity (Etype (gnat_node))
1251       && Nkind (Prefix (gnat_node)) == N_Identifier
1252       && Is_Subprogram (Entity (Prefix (gnat_node)))
1253       && Is_Public (Entity (Prefix (gnat_node)))
1254       && !present_gnu_tree (Entity (Prefix (gnat_node))))
1255     gnu_prefix = get_minimal_subprog_decl (Entity (Prefix (gnat_node)));
1256   else
1257     gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1258   gnu_type = TREE_TYPE (gnu_prefix);
1259
1260   /* If the input is a NULL_EXPR, make a new one.  */
1261   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1262     {
1263       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1264       *gnu_result_type_p = gnu_result_type;
1265       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1266     }
1267
1268   switch (attribute)
1269     {
1270     case Attr_Pos:
1271     case Attr_Val:
1272       /* These are just conversions since representation clauses for
1273          enumeration types are handled in the front-end.  */
1274       {
1275         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1276         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1277         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1278         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1279                                          checkp, checkp, true, gnat_node);
1280       }
1281       break;
1282
1283     case Attr_Pred:
1284     case Attr_Succ:
1285       /* These just add or subtract the constant 1 since representation
1286          clauses for enumeration types are handled in the front-end.  */
1287       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1288       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1289
1290       if (Do_Range_Check (First (Expressions (gnat_node))))
1291         {
1292           gnu_expr = gnat_protect_expr (gnu_expr);
1293           gnu_expr
1294             = emit_check
1295               (build_binary_op (EQ_EXPR, boolean_type_node,
1296                                 gnu_expr,
1297                                 attribute == Attr_Pred
1298                                 ? TYPE_MIN_VALUE (gnu_result_type)
1299                                 : TYPE_MAX_VALUE (gnu_result_type)),
1300                gnu_expr, CE_Range_Check_Failed, gnat_node);
1301         }
1302
1303       gnu_result
1304         = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1305                            gnu_result_type, gnu_expr,
1306                            convert (gnu_result_type, integer_one_node));
1307       break;
1308
1309     case Attr_Address:
1310     case Attr_Unrestricted_Access:
1311       /* Conversions don't change addresses but can cause us to miss the
1312          COMPONENT_REF case below, so strip them off.  */
1313       gnu_prefix = remove_conversions (gnu_prefix,
1314                                        !Must_Be_Byte_Aligned (gnat_node));
1315
1316       /* If we are taking 'Address of an unconstrained object, this is the
1317          pointer to the underlying array.  */
1318       if (attribute == Attr_Address)
1319         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1320
1321       /* If we are building a static dispatch table, we have to honor
1322          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1323          with the C++ ABI.  We do it in the non-static case as well,
1324          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
1325       else if (TARGET_VTABLE_USES_DESCRIPTORS
1326                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1327         {
1328           tree gnu_field, t;
1329           /* Descriptors can only be built here for top-level functions.  */
1330           bool build_descriptor = (global_bindings_p () != 0);
1331           int i;
1332           VEC(constructor_elt,gc) *gnu_vec = NULL;
1333           constructor_elt *elt;
1334
1335           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1336
1337           /* If we're not going to build the descriptor, we have to retrieve
1338              the one which will be built by the linker (or by the compiler
1339              later if a static chain is requested).  */
1340           if (!build_descriptor)
1341             {
1342               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1343               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1344                                          gnu_result);
1345               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1346             }
1347
1348           VEC_safe_grow (constructor_elt, gc, gnu_vec,
1349                          TARGET_VTABLE_USES_DESCRIPTORS);
1350           elt = (VEC_address (constructor_elt, gnu_vec)
1351                  + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1352           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1353                i < TARGET_VTABLE_USES_DESCRIPTORS;
1354                gnu_field = DECL_CHAIN (gnu_field), i++)
1355             {
1356               if (build_descriptor)
1357                 {
1358                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1359                               build_int_cst (NULL_TREE, i));
1360                   TREE_CONSTANT (t) = 1;
1361                 }
1362               else
1363                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1364                             gnu_field, NULL_TREE);
1365
1366               elt->index = gnu_field;
1367               elt->value = t;
1368               elt--;
1369             }
1370
1371           gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1372           break;
1373         }
1374
1375       /* ... fall through ... */
1376
1377     case Attr_Access:
1378     case Attr_Unchecked_Access:
1379     case Attr_Code_Address:
1380       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1381       gnu_result
1382         = build_unary_op (((attribute == Attr_Address
1383                             || attribute == Attr_Unrestricted_Access)
1384                            && !Must_Be_Byte_Aligned (gnat_node))
1385                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
1386                           gnu_result_type, gnu_prefix);
1387
1388       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1389          don't try to build a trampoline.  */
1390       if (attribute == Attr_Code_Address)
1391         {
1392           gnu_expr = remove_conversions (gnu_result, false);
1393
1394           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1395             TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1396         }
1397
1398       /* For 'Access, issue an error message if the prefix is a C++ method
1399          since it can use a special calling convention on some platforms,
1400          which cannot be propagated to the access type.  */
1401       else if (attribute == Attr_Access
1402                && Nkind (Prefix (gnat_node)) == N_Identifier
1403                && is_cplusplus_method (Entity (Prefix (gnat_node))))
1404         post_error ("access to C++ constructor or member function not allowed",
1405                     gnat_node);
1406
1407       /* For other address attributes applied to a nested function,
1408          find an inner ADDR_EXPR and annotate it so that we can issue
1409          a useful warning with -Wtrampolines.  */
1410       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1411         {
1412           gnu_expr = remove_conversions (gnu_result, false);
1413
1414           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1415               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1416             {
1417               set_expr_location_from_node (gnu_expr, gnat_node);
1418
1419               /* Check that we're not violating the No_Implicit_Dynamic_Code
1420                  restriction.  Be conservative if we don't know anything
1421                  about the trampoline strategy for the target.  */
1422               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1423             }
1424         }
1425       break;
1426
1427     case Attr_Pool_Address:
1428       {
1429         tree gnu_obj_type;
1430         tree gnu_ptr = gnu_prefix;
1431
1432         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1433
1434         /* If this is an unconstrained array, we know the object has been
1435            allocated with the template in front of the object.  So compute
1436            the template address.  */
1437         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1438           gnu_ptr
1439             = convert (build_pointer_type
1440                        (TYPE_OBJECT_RECORD_TYPE
1441                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1442                        gnu_ptr);
1443
1444         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1445         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1446             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1447           {
1448             tree gnu_char_ptr_type
1449               = build_pointer_type (unsigned_char_type_node);
1450             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1451             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1452             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1453                                        gnu_ptr, gnu_pos);
1454           }
1455
1456         gnu_result = convert (gnu_result_type, gnu_ptr);
1457       }
1458       break;
1459
1460     case Attr_Size:
1461     case Attr_Object_Size:
1462     case Attr_Value_Size:
1463     case Attr_Max_Size_In_Storage_Elements:
1464       gnu_expr = gnu_prefix;
1465
1466       /* Remove NOPs and conversions between original and packable version
1467          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1468          to see if a COMPONENT_REF was involved.  */
1469       while (TREE_CODE (gnu_expr) == NOP_EXPR
1470              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1471                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1472                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1473                     == RECORD_TYPE
1474                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1475                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1476         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1477
1478       gnu_prefix = remove_conversions (gnu_prefix, true);
1479       prefix_unused = true;
1480       gnu_type = TREE_TYPE (gnu_prefix);
1481
1482       /* Replace an unconstrained array type with the type of the underlying
1483          array.  We can't do this with a call to maybe_unconstrained_array
1484          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1485          use the record type that will be used to allocate the object and its
1486          template.  */
1487       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1488         {
1489           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1490           if (attribute != Attr_Max_Size_In_Storage_Elements)
1491             gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1492         }
1493
1494       /* If we're looking for the size of a field, return the field size.
1495          Otherwise, if the prefix is an object, or if we're looking for
1496          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1497          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1498       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1499         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1500       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1501                || attribute == Attr_Object_Size
1502                || attribute == Attr_Max_Size_In_Storage_Elements)
1503         {
1504           /* If the prefix is an object of a padded type, the GCC size isn't
1505              relevant to the programmer.  Normally what we want is the RM size,
1506              which was set from the specified size, but if it was not set, we
1507              want the size of the field.  Using the MAX of those two produces
1508              the right result in all cases.  Don't use the size of the field
1509              if it's self-referential, since that's never what's wanted.  */
1510           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1511               && TYPE_IS_PADDING_P (gnu_type)
1512               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1513             {
1514               gnu_result = rm_size (gnu_type);
1515               if (!CONTAINS_PLACEHOLDER_P
1516                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1517                 gnu_result
1518                   = size_binop (MAX_EXPR, gnu_result,
1519                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1520             }
1521           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1522             {
1523               Node_Id gnat_deref = Prefix (gnat_node);
1524               Node_Id gnat_actual_subtype
1525                 = Actual_Designated_Subtype (gnat_deref);
1526               tree gnu_ptr_type
1527                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1528
1529               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1530                   && Present (gnat_actual_subtype))
1531                 {
1532                   tree gnu_actual_obj_type
1533                     = gnat_to_gnu_type (gnat_actual_subtype);
1534                   gnu_type
1535                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1536                                                       gnu_actual_obj_type,
1537                                                       get_identifier ("SIZE"),
1538                                                       false);
1539                 }
1540
1541               gnu_result = TYPE_SIZE (gnu_type);
1542             }
1543           else
1544             gnu_result = TYPE_SIZE (gnu_type);
1545         }
1546       else
1547         gnu_result = rm_size (gnu_type);
1548
1549       /* Deal with a self-referential size by returning the maximum size for
1550          a type and by qualifying the size with the object otherwise.  */
1551       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1552         {
1553           if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1554             gnu_result = max_size (gnu_result, true);
1555           else
1556             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1557         }
1558
1559       /* If the type contains a template, subtract its size.  */
1560       if (TREE_CODE (gnu_type) == RECORD_TYPE
1561           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1562         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1563                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1564
1565       /* For 'Max_Size_In_Storage_Elements, adjust the unit.  */
1566       if (attribute == Attr_Max_Size_In_Storage_Elements)
1567         gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1568
1569       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1570       break;
1571
1572     case Attr_Alignment:
1573       {
1574         unsigned int align;
1575
1576         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1577             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1578           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1579
1580         gnu_type = TREE_TYPE (gnu_prefix);
1581         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1582         prefix_unused = true;
1583
1584         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1585           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1586         else
1587           {
1588             Node_Id gnat_prefix = Prefix (gnat_node);
1589             Entity_Id gnat_type = Etype (gnat_prefix);
1590             unsigned int double_align;
1591             bool is_capped_double, align_clause;
1592
1593             /* If the default alignment of "double" or larger scalar types is
1594                specifically capped and there is an alignment clause neither
1595                on the type nor on the prefix itself, return the cap.  */
1596             if ((double_align = double_float_alignment) > 0)
1597               is_capped_double
1598                 = is_double_float_or_array (gnat_type, &align_clause);
1599             else if ((double_align = double_scalar_alignment) > 0)
1600               is_capped_double
1601                 = is_double_scalar_or_array (gnat_type, &align_clause);
1602             else
1603               is_capped_double = align_clause = false;
1604
1605             if (is_capped_double
1606                 && Nkind (gnat_prefix) == N_Identifier
1607                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1608               align_clause = true;
1609
1610             if (is_capped_double && !align_clause)
1611               align = double_align;
1612             else
1613               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1614           }
1615
1616         gnu_result = size_int (align);
1617       }
1618       break;
1619
1620     case Attr_First:
1621     case Attr_Last:
1622     case Attr_Range_Length:
1623       prefix_unused = true;
1624
1625       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1626         {
1627           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1628
1629           if (attribute == Attr_First)
1630             gnu_result = TYPE_MIN_VALUE (gnu_type);
1631           else if (attribute == Attr_Last)
1632             gnu_result = TYPE_MAX_VALUE (gnu_type);
1633           else
1634             gnu_result
1635               = build_binary_op
1636                 (MAX_EXPR, get_base_type (gnu_result_type),
1637                  build_binary_op
1638                  (PLUS_EXPR, get_base_type (gnu_result_type),
1639                   build_binary_op (MINUS_EXPR,
1640                                    get_base_type (gnu_result_type),
1641                                    convert (gnu_result_type,
1642                                             TYPE_MAX_VALUE (gnu_type)),
1643                                    convert (gnu_result_type,
1644                                             TYPE_MIN_VALUE (gnu_type))),
1645                   convert (gnu_result_type, integer_one_node)),
1646                  convert (gnu_result_type, integer_zero_node));
1647
1648           break;
1649         }
1650
1651       /* ... fall through ... */
1652
1653     case Attr_Length:
1654       {
1655         int Dimension = (Present (Expressions (gnat_node))
1656                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1657                          : 1), i;
1658         struct parm_attr_d *pa = NULL;
1659         Entity_Id gnat_param = Empty;
1660
1661         /* Make sure any implicit dereference gets done.  */
1662         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1663         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1664
1665         /* We treat unconstrained array In parameters specially.  */
1666         if (!Is_Constrained (Etype (Prefix (gnat_node))))
1667           {
1668             Node_Id gnat_prefix = Prefix (gnat_node);
1669
1670             /* This is the direct case.  */
1671             if (Nkind (gnat_prefix) == N_Identifier
1672                 && Ekind (Entity (gnat_prefix)) == E_In_Parameter)
1673               gnat_param = Entity (gnat_prefix);
1674
1675             /* This is the indirect case.  Note that we need to be sure that
1676                the access value cannot be null as we'll hoist the load.  */
1677             if (Nkind (gnat_prefix) == N_Explicit_Dereference
1678                 && Nkind (Prefix (gnat_prefix)) == N_Identifier
1679                 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter
1680                 && Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
1681               gnat_param = Entity (Prefix (gnat_prefix));
1682           }
1683
1684         gnu_type = TREE_TYPE (gnu_prefix);
1685         prefix_unused = true;
1686         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1687
1688         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1689           {
1690             int ndim;
1691             tree gnu_type_temp;
1692
1693             for (ndim = 1, gnu_type_temp = gnu_type;
1694                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1695                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1696                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1697               ;
1698
1699             Dimension = ndim + 1 - Dimension;
1700           }
1701
1702         for (i = 1; i < Dimension; i++)
1703           gnu_type = TREE_TYPE (gnu_type);
1704
1705         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1706
1707         /* When not optimizing, look up the slot associated with the parameter
1708            and the dimension in the cache and create a new one on failure.  */
1709         if (!optimize && Present (gnat_param))
1710           {
1711             FOR_EACH_VEC_ELT (parm_attr, f_parm_attr_cache, i, pa)
1712               if (pa->id == gnat_param && pa->dim == Dimension)
1713                 break;
1714
1715             if (!pa)
1716               {
1717                 pa = ggc_alloc_cleared_parm_attr_d ();
1718                 pa->id = gnat_param;
1719                 pa->dim = Dimension;
1720                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1721               }
1722           }
1723
1724         /* Return the cached expression or build a new one.  */
1725         if (attribute == Attr_First)
1726           {
1727             if (pa && pa->first)
1728               {
1729                 gnu_result = pa->first;
1730                 break;
1731               }
1732
1733             gnu_result
1734               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1735           }
1736
1737         else if (attribute == Attr_Last)
1738           {
1739             if (pa && pa->last)
1740               {
1741                 gnu_result = pa->last;
1742                 break;
1743               }
1744
1745             gnu_result
1746               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1747           }
1748
1749         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1750           {
1751             if (pa && pa->length)
1752               {
1753                 gnu_result = pa->length;
1754                 break;
1755               }
1756             else
1757               {
1758                 /* We used to compute the length as max (hb - lb + 1, 0),
1759                    which could overflow for some cases of empty arrays, e.g.
1760                    when lb == index_type'first.  We now compute the length as
1761                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1762                    much rarer cases, for extremely large arrays we expect
1763                    never to encounter in practice.  In addition, the former
1764                    computation required the use of potentially constraining
1765                    signed arithmetic while the latter doesn't.  Note that
1766                    the comparison must be done in the original index type,
1767                    to avoid any overflow during the conversion.  */
1768                 tree comp_type = get_base_type (gnu_result_type);
1769                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1770                 tree lb = TYPE_MIN_VALUE (index_type);
1771                 tree hb = TYPE_MAX_VALUE (index_type);
1772                 gnu_result
1773                   = build_binary_op (PLUS_EXPR, comp_type,
1774                                      build_binary_op (MINUS_EXPR,
1775                                                       comp_type,
1776                                                       convert (comp_type, hb),
1777                                                       convert (comp_type, lb)),
1778                                      convert (comp_type, integer_one_node));
1779                 gnu_result
1780                   = build_cond_expr (comp_type,
1781                                      build_binary_op (GE_EXPR,
1782                                                       boolean_type_node,
1783                                                       hb, lb),
1784                                      gnu_result,
1785                                      convert (comp_type, integer_zero_node));
1786               }
1787           }
1788
1789         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1790            handling.  Note that these attributes could not have been used on
1791            an unconstrained array type.  */
1792         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1793
1794         /* Cache the expression we have just computed.  Since we want to do it
1795            at run time, we force the use of a SAVE_EXPR and let the gimplifier
1796            create the temporary in the outermost binding level.  We will make
1797            sure in Subprogram_Body_to_gnu that it is evaluated on all possible
1798            paths by forcing its evaluation on entry of the function.  */
1799         if (pa)
1800           {
1801             gnu_result
1802               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1803             if (attribute == Attr_First)
1804               pa->first = gnu_result;
1805             else if (attribute == Attr_Last)
1806               pa->last = gnu_result;
1807             else
1808               pa->length = gnu_result;
1809           }
1810
1811         /* Set the source location onto the predicate of the condition in the
1812            'Length case but do not do it if the expression is cached to avoid
1813            messing up the debug info.  */
1814         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1815                  && TREE_CODE (gnu_result) == COND_EXPR
1816                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1817           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1818                                        gnat_node);
1819
1820         break;
1821       }
1822
1823     case Attr_Bit_Position:
1824     case Attr_Position:
1825     case Attr_First_Bit:
1826     case Attr_Last_Bit:
1827     case Attr_Bit:
1828       {
1829         HOST_WIDE_INT bitsize;
1830         HOST_WIDE_INT bitpos;
1831         tree gnu_offset;
1832         tree gnu_field_bitpos;
1833         tree gnu_field_offset;
1834         tree gnu_inner;
1835         enum machine_mode mode;
1836         int unsignedp, volatilep;
1837
1838         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1839         gnu_prefix = remove_conversions (gnu_prefix, true);
1840         prefix_unused = true;
1841
1842         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1843            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1844         if (attribute == Attr_Bit
1845             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1846             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1847           {
1848             gnu_result = integer_zero_node;
1849             break;
1850           }
1851
1852         else
1853           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1854                       || (attribute == Attr_Bit_Position
1855                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1856
1857         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1858                              &mode, &unsignedp, &volatilep, false);
1859
1860         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1861           {
1862             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1863             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1864
1865             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1866                  TREE_CODE (gnu_inner) == COMPONENT_REF
1867                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1868                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1869               {
1870                 gnu_field_bitpos
1871                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1872                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1873                 gnu_field_offset
1874                   = size_binop (PLUS_EXPR, gnu_field_offset,
1875                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1876               }
1877           }
1878         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1879           {
1880             gnu_field_bitpos = bit_position (gnu_prefix);
1881             gnu_field_offset = byte_position (gnu_prefix);
1882           }
1883         else
1884           {
1885             gnu_field_bitpos = bitsize_zero_node;
1886             gnu_field_offset = size_zero_node;
1887           }
1888
1889         switch (attribute)
1890           {
1891           case Attr_Position:
1892             gnu_result = gnu_field_offset;
1893             break;
1894
1895           case Attr_First_Bit:
1896           case Attr_Bit:
1897             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1898             break;
1899
1900           case Attr_Last_Bit:
1901             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1902             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1903                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1904             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1905                                      bitsize_one_node);
1906             break;
1907
1908           case Attr_Bit_Position:
1909             gnu_result = gnu_field_bitpos;
1910             break;
1911                 }
1912
1913         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1914            handling.  */
1915         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1916         break;
1917       }
1918
1919     case Attr_Min:
1920     case Attr_Max:
1921       {
1922         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1923         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1924
1925         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1926         gnu_result = build_binary_op (attribute == Attr_Min
1927                                       ? MIN_EXPR : MAX_EXPR,
1928                                       gnu_result_type, gnu_lhs, gnu_rhs);
1929       }
1930       break;
1931
1932     case Attr_Passed_By_Reference:
1933       gnu_result = size_int (default_pass_by_ref (gnu_type)
1934                              || must_pass_by_ref (gnu_type));
1935       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1936       break;
1937
1938     case Attr_Component_Size:
1939       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1940           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1941         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1942
1943       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1944       gnu_type = TREE_TYPE (gnu_prefix);
1945
1946       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1947         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1948
1949       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1950              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1951         gnu_type = TREE_TYPE (gnu_type);
1952
1953       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1954
1955       /* Note this size cannot be self-referential.  */
1956       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1957       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1958       prefix_unused = true;
1959       break;
1960
1961     case Attr_Descriptor_Size:
1962       gnu_type = TREE_TYPE (gnu_prefix);
1963       gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
1964
1965       /* What we want is the offset of the ARRAY field in the record that the
1966         thin pointer designates, but the components have been shifted so this
1967         is actually the opposite of the offset of the BOUNDS field.  */
1968       gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1969       gnu_result = size_binop (MINUS_EXPR, bitsize_zero_node,
1970                                bit_position (TYPE_FIELDS (gnu_type)));
1971       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1972       prefix_unused = true;
1973       break;
1974
1975     case Attr_Null_Parameter:
1976       /* This is just a zero cast to the pointer type for our prefix and
1977          dereferenced.  */
1978       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1979       gnu_result
1980         = build_unary_op (INDIRECT_REF, NULL_TREE,
1981                           convert (build_pointer_type (gnu_result_type),
1982                                    integer_zero_node));
1983       TREE_PRIVATE (gnu_result) = 1;
1984       break;
1985
1986     case Attr_Mechanism_Code:
1987       {
1988         int code;
1989         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1990
1991         prefix_unused = true;
1992         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1993         if (Present (Expressions (gnat_node)))
1994           {
1995             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1996
1997             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1998                  i--, gnat_obj = Next_Formal (gnat_obj))
1999               ;
2000           }
2001
2002         code = Mechanism (gnat_obj);
2003         if (code == Default)
2004           code = ((present_gnu_tree (gnat_obj)
2005                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
2006                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
2007                             == PARM_DECL)
2008                            && (DECL_BY_COMPONENT_PTR_P
2009                                (get_gnu_tree (gnat_obj))))))
2010                   ? By_Reference : By_Copy);
2011         gnu_result = convert (gnu_result_type, size_int (- code));
2012       }
2013       break;
2014
2015     default:
2016       /* Say we have an unimplemented attribute.  Then set the value to be
2017          returned to be a zero and hope that's something we can convert to
2018          the type of this attribute.  */
2019       post_error ("unimplemented attribute", gnat_node);
2020       gnu_result_type = get_unpadded_type (Etype (gnat_node));
2021       gnu_result = integer_zero_node;
2022       break;
2023     }
2024
2025   /* If this is an attribute where the prefix was unused, force a use of it if
2026      it has a side-effect.  But don't do it if the prefix is just an entity
2027      name.  However, if an access check is needed, we must do it.  See second
2028      example in AARM 11.6(5.e).  */
2029   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
2030       && !Is_Entity_Name (Prefix (gnat_node)))
2031     gnu_result = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix,
2032                                        gnu_result);
2033
2034   *gnu_result_type_p = gnu_result_type;
2035   return gnu_result;
2036 }
2037 \f
2038 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2039    to a GCC tree, which is returned.  */
2040
2041 static tree
2042 Case_Statement_to_gnu (Node_Id gnat_node)
2043 {
2044   tree gnu_result, gnu_expr, gnu_label;
2045   Node_Id gnat_when;
2046   location_t end_locus;
2047   bool may_fallthru = false;
2048
2049   gnu_expr = gnat_to_gnu (Expression (gnat_node));
2050   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2051
2052   /*  The range of values in a case statement is determined by the rules in
2053       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
2054       of the expression. One exception arises in the case of a simple name that
2055       is parenthesized. This still has the Etype of the name, but since it is
2056       not a name, para 7 does not apply, and we need to go to the base type.
2057       This is the only case where parenthesization affects the dynamic
2058       semantics (i.e. the range of possible values at run time that is covered
2059       by the others alternative).
2060
2061       Another exception is if the subtype of the expression is non-static.  In
2062       that case, we also have to use the base type.  */
2063   if (Paren_Count (Expression (gnat_node)) != 0
2064       || !Is_OK_Static_Subtype (Underlying_Type
2065                                 (Etype (Expression (gnat_node)))))
2066     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2067
2068   /* We build a SWITCH_EXPR that contains the code with interspersed
2069      CASE_LABEL_EXPRs for each label.  */
2070   if (!Sloc_to_locus (Sloc (gnat_node) + UI_To_Int (End_Span (gnat_node)),
2071       &end_locus))
2072     end_locus = input_location;
2073   gnu_label = create_artificial_label (end_locus);
2074   start_stmt_group ();
2075
2076   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2077        Present (gnat_when);
2078        gnat_when = Next_Non_Pragma (gnat_when))
2079     {
2080       bool choices_added_p = false;
2081       Node_Id gnat_choice;
2082
2083       /* First compile all the different case choices for the current WHEN
2084          alternative.  */
2085       for (gnat_choice = First (Discrete_Choices (gnat_when));
2086            Present (gnat_choice); gnat_choice = Next (gnat_choice))
2087         {
2088           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2089
2090           switch (Nkind (gnat_choice))
2091             {
2092             case N_Range:
2093               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2094               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2095               break;
2096
2097             case N_Subtype_Indication:
2098               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2099                                                 (Constraint (gnat_choice))));
2100               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2101                                                   (Constraint (gnat_choice))));
2102               break;
2103
2104             case N_Identifier:
2105             case N_Expanded_Name:
2106               /* This represents either a subtype range or a static value of
2107                  some kind; Ekind says which.  */
2108               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2109                 {
2110                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2111
2112                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
2113                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
2114                   break;
2115                 }
2116
2117               /* ... fall through ... */
2118
2119             case N_Character_Literal:
2120             case N_Integer_Literal:
2121               gnu_low = gnat_to_gnu (gnat_choice);
2122               break;
2123
2124             case N_Others_Choice:
2125               break;
2126
2127             default:
2128               gcc_unreachable ();
2129             }
2130
2131           /* If the case value is a subtype that raises Constraint_Error at
2132              run time because of a wrong bound, then gnu_low or gnu_high is
2133              not translated into an INTEGER_CST.  In such a case, we need
2134              to ensure that the when statement is not added in the tree,
2135              otherwise it will crash the gimplifier.  */
2136           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2137               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2138             {
2139               add_stmt_with_node (build_case_label
2140                                   (gnu_low, gnu_high,
2141                                    create_artificial_label (input_location)),
2142                                   gnat_choice);
2143               choices_added_p = true;
2144             }
2145         }
2146
2147       /* Push a binding level here in case variables are declared as we want
2148          them to be local to this set of statements instead of to the block
2149          containing the Case statement.  */
2150       if (choices_added_p)
2151         {
2152           tree group = build_stmt_group (Statements (gnat_when), true);
2153           bool group_may_fallthru = block_may_fallthru (group);
2154           add_stmt (group);
2155           if (group_may_fallthru)
2156             {
2157               tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2158               SET_EXPR_LOCATION (stmt, end_locus);
2159               add_stmt (stmt);
2160               may_fallthru = true;
2161             }
2162         }
2163     }
2164
2165   /* Now emit a definition of the label the cases branch to, if any.  */
2166   if (may_fallthru)
2167     add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2168   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2169                        end_stmt_group (), NULL_TREE);
2170
2171   return gnu_result;
2172 }
2173 \f
2174 /* Find out whether VAR is an iteration variable of an enclosing loop in the
2175    current function.  If so, push a range_check_info structure onto the stack
2176    of this enclosing loop and return it.  Otherwise, return NULL.  */
2177
2178 static struct range_check_info_d *
2179 push_range_check_info (tree var)
2180 {
2181   struct loop_info_d *iter = NULL;
2182   unsigned int i;
2183
2184   if (VEC_empty (loop_info, gnu_loop_stack))
2185     return NULL;
2186
2187   var = remove_conversions (var, false);
2188
2189   if (TREE_CODE (var) != VAR_DECL)
2190     return NULL;
2191
2192   if (decl_function_context (var) != current_function_decl)
2193     return NULL;
2194
2195   for (i = VEC_length (loop_info, gnu_loop_stack) - 1;
2196        VEC_iterate (loop_info, gnu_loop_stack, i, iter);
2197        i--)
2198     if (var == iter->loop_var)
2199       break;
2200
2201   if (iter)
2202     {
2203       struct range_check_info_d *rci = ggc_alloc_range_check_info_d ();
2204       VEC_safe_push (range_check_info, gc, iter->checks, rci);
2205       return rci;
2206     }
2207
2208   return NULL;
2209 }
2210
2211 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2212    false, or the maximum value if MAX is true, of TYPE.  */
2213
2214 static bool
2215 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2216 {
2217   tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2218
2219   if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2220     return true;
2221
2222   if (TREE_CODE (val) == NOP_EXPR)
2223     val = (max
2224            ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2225            : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2226
2227   if (TREE_CODE (val) != INTEGER_CST)
2228     return true;
2229
2230   return tree_int_cst_equal (val, min_or_max_val) == 1;
2231 }
2232
2233 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2234    If REVERSE is true, minimum value is taken as maximum value.  */
2235
2236 static inline bool
2237 can_equal_min_val_p (tree val, tree type, bool reverse)
2238 {
2239   return can_equal_min_or_max_val_p (val, type, reverse);
2240 }
2241
2242 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2243    If REVERSE is true, maximum value is taken as minimum value.  */
2244
2245 static inline bool
2246 can_equal_max_val_p (tree val, tree type, bool reverse)
2247 {
2248   return can_equal_min_or_max_val_p (val, type, !reverse);
2249 }
2250
2251 /* Return true if VAL1 can be lower than VAL2.  */
2252
2253 static bool
2254 can_be_lower_p (tree val1, tree val2)
2255 {
2256   if (TREE_CODE (val1) == NOP_EXPR)
2257     val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2258
2259   if (TREE_CODE (val1) != INTEGER_CST)
2260     return true;
2261
2262   if (TREE_CODE (val2) == NOP_EXPR)
2263     val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2264
2265   if (TREE_CODE (val2) != INTEGER_CST)
2266     return true;
2267
2268   return tree_int_cst_lt (val1, val2);
2269 }
2270
2271 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2272    to a GCC tree, which is returned.  */
2273
2274 static tree
2275 Loop_Statement_to_gnu (Node_Id gnat_node)
2276 {
2277   const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2278   struct loop_info_d *gnu_loop_info = ggc_alloc_cleared_loop_info_d ();
2279   tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2280                                NULL_TREE, NULL_TREE, NULL_TREE);
2281   tree gnu_loop_label = create_artificial_label (input_location);
2282   tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2283   tree gnu_result;
2284
2285   /* Push the loop_info structure associated with the LOOP_STMT.  */
2286   VEC_safe_push (loop_info, gc, gnu_loop_stack, gnu_loop_info);
2287
2288   /* Set location information for statement and end label.  */
2289   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2290   Sloc_to_locus (Sloc (End_Label (gnat_node)),
2291                  &DECL_SOURCE_LOCATION (gnu_loop_label));
2292   LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2293
2294   /* Save the label so that a corresponding N_Exit_Statement can find it.  */
2295   gnu_loop_info->label = gnu_loop_label;
2296
2297   /* Set the condition under which the loop must keep going.
2298      For the case "LOOP .... END LOOP;" the condition is always true.  */
2299   if (No (gnat_iter_scheme))
2300     ;
2301
2302   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2303   else if (Present (Condition (gnat_iter_scheme)))
2304     LOOP_STMT_COND (gnu_loop_stmt)
2305       = gnat_to_gnu (Condition (gnat_iter_scheme));
2306
2307   /* Otherwise we have an iteration scheme and the condition is given by the
2308      bounds of the subtype of the iteration variable.  */
2309   else
2310     {
2311       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2312       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2313       Entity_Id gnat_type = Etype (gnat_loop_var);
2314       tree gnu_type = get_unpadded_type (gnat_type);
2315       tree gnu_base_type = get_base_type (gnu_type);
2316       tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2317       tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2318       enum tree_code update_code, test_code, shift_code;
2319       bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2320
2321       gnu_low = TYPE_MIN_VALUE (gnu_type);
2322       gnu_high = TYPE_MAX_VALUE (gnu_type);
2323
2324       /* We must disable modulo reduction for the iteration variable, if any,
2325          in order for the loop comparison to be effective.  */
2326       if (reverse)
2327         {
2328           gnu_first = gnu_high;
2329           gnu_last = gnu_low;
2330           update_code = MINUS_NOMOD_EXPR;
2331           test_code = GE_EXPR;
2332           shift_code = PLUS_NOMOD_EXPR;
2333         }
2334       else
2335         {
2336           gnu_first = gnu_low;
2337           gnu_last = gnu_high;
2338           update_code = PLUS_NOMOD_EXPR;
2339           test_code = LE_EXPR;
2340           shift_code = MINUS_NOMOD_EXPR;
2341         }
2342
2343       /* We use two different strategies to translate the loop, depending on
2344          whether optimization is enabled.
2345
2346          If it is, we generate the canonical loop form expected by the loop
2347          optimizer and the loop vectorizer, which is the do-while form:
2348
2349              ENTRY_COND
2350            loop:
2351              TOP_UPDATE
2352              BODY
2353              BOTTOM_COND
2354              GOTO loop
2355
2356          This avoids an implicit dependency on loop header copying and makes
2357          it possible to turn BOTTOM_COND into an inequality test.
2358
2359          If optimization is disabled, loop header copying doesn't come into
2360          play and we try to generate the loop form with the fewer conditional
2361          branches.  First, the default form, which is:
2362
2363            loop:
2364              TOP_COND
2365              BODY
2366              BOTTOM_UPDATE
2367              GOTO loop
2368
2369          It should catch most loops with constant ending point.  Then, if we
2370          cannot, we try to generate the shifted form:
2371
2372            loop:
2373              TOP_COND
2374              TOP_UPDATE
2375              BODY
2376              GOTO loop
2377
2378          which should catch loops with constant starting point.  Otherwise, if
2379          we cannot, we generate the fallback form:
2380
2381              ENTRY_COND
2382            loop:
2383              BODY
2384              BOTTOM_COND
2385              BOTTOM_UPDATE
2386              GOTO loop
2387
2388          which works in all cases.  */
2389
2390       if (optimize)
2391         {
2392           /* We can use the do-while form directly if GNU_FIRST-1 doesn't
2393              overflow.  */
2394           if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2395             ;
2396
2397           /* Otherwise, use the do-while form with the help of a special
2398              induction variable in the unsigned version of the base type
2399              or the unsigned version of the size type, whichever is the
2400              largest, in order to have wrap-around arithmetics for it.  */
2401           else
2402             {
2403               if (TYPE_PRECISION (gnu_base_type)
2404                   > TYPE_PRECISION (size_type_node))
2405                 gnu_base_type = gnat_unsigned_type (gnu_base_type);
2406               else
2407                 gnu_base_type = size_type_node;
2408
2409               gnu_first = convert (gnu_base_type, gnu_first);
2410               gnu_last = convert (gnu_base_type, gnu_last);
2411               gnu_one_node = convert (gnu_base_type, integer_one_node);
2412               use_iv = true;
2413             }
2414
2415           gnu_first
2416             = build_binary_op (shift_code, gnu_base_type, gnu_first,
2417                                gnu_one_node);
2418           LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2419           LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2420         }
2421       else
2422         {
2423           /* We can use the default form if GNU_LAST+1 doesn't overflow.  */
2424           if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2425             ;
2426
2427           /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2428              GNU_LAST-1 does.  */
2429           else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2430                    && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2431             {
2432               gnu_first
2433                 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2434                                    gnu_one_node);
2435               gnu_last
2436                 = build_binary_op (shift_code, gnu_base_type, gnu_last,
2437                                    gnu_one_node);
2438               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2439             }
2440
2441           /* Otherwise, use the fallback form.  */
2442           else
2443             LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2444         }
2445
2446       /* If we use the BOTTOM_COND, we can turn the test into an inequality
2447          test but we may have to add ENTRY_COND to protect the empty loop.  */
2448       if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2449         {
2450           test_code = NE_EXPR;
2451           if (can_be_lower_p (gnu_high, gnu_low))
2452             {
2453               gnu_cond_expr
2454                 = build3 (COND_EXPR, void_type_node,
2455                           build_binary_op (LE_EXPR, boolean_type_node,
2456                                            gnu_low, gnu_high),
2457                           NULL_TREE, alloc_stmt_list ());
2458               set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2459             }
2460         }
2461
2462       /* Open a new nesting level that will surround the loop to declare the
2463          iteration variable.  */
2464       start_stmt_group ();
2465       gnat_pushlevel ();
2466
2467       /* If we use the special induction variable, create it and set it to
2468          its initial value.  Morever, the regular iteration variable cannot
2469          itself be initialized, lest the initial value wrapped around.  */
2470       if (use_iv)
2471         {
2472           gnu_loop_iv
2473             = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
2474           add_stmt (gnu_stmt);
2475           gnu_first = NULL_TREE;
2476         }
2477       else
2478         gnu_loop_iv = NULL_TREE;
2479
2480       /* Declare the iteration variable and set it to its initial value.  */
2481       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2482       if (DECL_BY_REF_P (gnu_loop_var))
2483         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2484       else if (use_iv)
2485         {
2486           gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
2487           SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
2488         }
2489       gnu_loop_info->loop_var = gnu_loop_var;
2490
2491       /* Do all the arithmetics in the base type.  */
2492       gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2493
2494       /* Set either the top or bottom exit condition.  */
2495       if (use_iv)
2496         LOOP_STMT_COND (gnu_loop_stmt)
2497           = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
2498                              gnu_last);
2499       else
2500         LOOP_STMT_COND (gnu_loop_stmt)
2501           = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2502                              gnu_last);
2503
2504       /* Set either the top or bottom update statement and give it the source
2505          location of the iteration for better coverage info.  */
2506       if (use_iv)
2507         {
2508           gnu_stmt
2509             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
2510                                build_binary_op (update_code, gnu_base_type,
2511                                                 gnu_loop_iv, gnu_one_node));
2512           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2513           append_to_statement_list (gnu_stmt,
2514                                     &LOOP_STMT_UPDATE (gnu_loop_stmt));
2515           gnu_stmt
2516             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2517                                gnu_loop_iv);
2518           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2519           append_to_statement_list (gnu_stmt,
2520                                     &LOOP_STMT_UPDATE (gnu_loop_stmt));
2521         }
2522       else
2523         {
2524           gnu_stmt
2525             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2526                                build_binary_op (update_code, gnu_base_type,
2527                                                 gnu_loop_var, gnu_one_node));
2528           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2529           LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
2530         }
2531     }
2532
2533   /* If the loop was named, have the name point to this loop.  In this case,
2534      the association is not a DECL node, but the end label of the loop.  */
2535   if (Present (Identifier (gnat_node)))
2536     save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2537
2538   /* Make the loop body into its own block, so any allocated storage will be
2539      released every iteration.  This is needed for stack allocation.  */
2540   LOOP_STMT_BODY (gnu_loop_stmt)
2541     = build_stmt_group (Statements (gnat_node), true);
2542   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2543
2544   /* If we have an iteration scheme, then we are in a statement group.  Add
2545      the LOOP_STMT to it, finish it and make it the "loop".  */
2546   if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
2547     {
2548       struct range_check_info_d *rci;
2549       unsigned n_checks = VEC_length (range_check_info, gnu_loop_info->checks);
2550       unsigned int i;
2551
2552       /* First, if we have computed a small number of invariant conditions for
2553          range checks applied to the iteration variable, then initialize these
2554          conditions in front of the loop.  Otherwise, leave them set to True.
2555
2556          ??? The heuristics need to be improved, by taking into account the
2557              following datapoints:
2558                - loop unswitching is disabled for big loops.  The cap is the
2559                  parameter PARAM_MAX_UNSWITCH_INSNS (50).
2560                - loop unswitching can only be applied a small number of times
2561                  to a given loop.  The cap is PARAM_MAX_UNSWITCH_LEVEL (3).
2562                - the front-end quickly generates useless or redundant checks
2563                  that can be entirely optimized away in the end.  */
2564       if (1 <= n_checks && n_checks <= 4)
2565         for (i = 0;
2566              VEC_iterate (range_check_info, gnu_loop_info->checks, i, rci);
2567              i++)
2568           {
2569             tree low_ok
2570               = build_binary_op (GE_EXPR, boolean_type_node,
2571                                  convert (rci->type, gnu_low),
2572                                  rci->low_bound);
2573             tree high_ok
2574               = build_binary_op (LE_EXPR, boolean_type_node,
2575                                  convert (rci->type, gnu_high),
2576                                  rci->high_bound);
2577             tree range_ok
2578               = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
2579                                  low_ok, high_ok);
2580
2581             TREE_OPERAND (rci->invariant_cond, 0)
2582               = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
2583
2584             add_stmt_with_node_force (rci->invariant_cond, gnat_node);
2585           }
2586
2587       add_stmt (gnu_loop_stmt);
2588       gnat_poplevel ();
2589       gnu_loop_stmt = end_stmt_group ();
2590     }
2591
2592   /* If we have an outer COND_EXPR, that's our result and this loop is its
2593      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2594   if (gnu_cond_expr)
2595     {
2596       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2597       gnu_result = gnu_cond_expr;
2598       recalculate_side_effects (gnu_cond_expr);
2599     }
2600   else
2601     gnu_result = gnu_loop_stmt;
2602
2603   VEC_pop (loop_info, gnu_loop_stack);
2604
2605   return gnu_result;
2606 }
2607 \f
2608 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2609    handler for the current function.  */
2610
2611 /* This is implemented by issuing a call to the appropriate VMS specific
2612    builtin.  To avoid having VMS specific sections in the global gigi decls
2613    array, we maintain the decls of interest here.  We can't declare them
2614    inside the function because we must mark them never to be GC'd, which we
2615    can only do at the global level.  */
2616
2617 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2618 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2619
2620 static void
2621 establish_gnat_vms_condition_handler (void)
2622 {
2623   tree establish_stmt;
2624
2625   /* Elaborate the required decls on the first call.  Check on the decl for
2626      the gnat condition handler to decide, as this is one we create so we are
2627      sure that it will be non null on subsequent calls.  The builtin decl is
2628      looked up so remains null on targets where it is not implemented yet.  */
2629   if (gnat_vms_condition_handler_decl == NULL_TREE)
2630     {
2631       vms_builtin_establish_handler_decl
2632         = builtin_decl_for
2633           (get_identifier ("__builtin_establish_vms_condition_handler"));
2634
2635       gnat_vms_condition_handler_decl
2636         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2637                                NULL_TREE,
2638                                build_function_type_list (boolean_type_node,
2639                                                          ptr_void_type_node,
2640                                                          ptr_void_type_node,
2641                                                          NULL_TREE),
2642                                NULL_TREE, false, true, true, true, NULL,
2643                                Empty);
2644
2645       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2646       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2647     }
2648
2649   /* Do nothing if the establish builtin is not available, which might happen
2650      on targets where the facility is not implemented.  */
2651   if (vms_builtin_establish_handler_decl == NULL_TREE)
2652     return;
2653
2654   establish_stmt
2655     = build_call_n_expr (vms_builtin_establish_handler_decl, 1,
2656                          build_unary_op
2657                          (ADDR_EXPR, NULL_TREE,
2658                           gnat_vms_condition_handler_decl));
2659
2660   add_stmt (establish_stmt);
2661 }
2662
2663 /* This page implements a form of Named Return Value optimization modelled
2664    on the C++ optimization of the same name.  The main difference is that
2665    we disregard any semantical considerations when applying it here, the
2666    counterpart being that we don't try to apply it to semantically loaded
2667    return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
2668
2669    We consider a function body of the following GENERIC form:
2670
2671      return_type R1;
2672        [...]
2673      RETURN_EXPR [<retval> = ...]
2674        [...]
2675      RETURN_EXPR [<retval> = R1]
2676        [...]
2677      return_type Ri;
2678        [...]
2679      RETURN_EXPR [<retval> = ...]
2680        [...]
2681      RETURN_EXPR [<retval> = Ri]
2682        [...]
2683
2684    and we try to fulfill a simple criterion that would make it possible to
2685    replace one or several Ri variables with the RESULT_DECL of the function.
2686
2687    The first observation is that RETURN_EXPRs that don't directly reference
2688    any of the Ri variables on the RHS of their assignment are transparent wrt
2689    the optimization.  This is because the Ri variables aren't addressable so
2690    any transformation applied to them doesn't affect the RHS; moreover, the
2691    assignment writes the full <retval> object so existing values are entirely
2692    discarded.
2693
2694    This property can be extended to some forms of RETURN_EXPRs that reference
2695    the Ri variables, for example CONSTRUCTORs, but isn't true in the general
2696    case, in particular when function calls are involved.
2697
2698    Therefore the algorithm is as follows:
2699
2700      1. Collect the list of candidates for a Named Return Value (Ri variables
2701         on the RHS of assignments of RETURN_EXPRs) as well as the list of the
2702         other expressions on the RHS of such assignments.
2703
2704      2. Prune the members of the first list (candidates) that are referenced
2705         by a member of the second list (expressions).
2706
2707      3. Extract a set of candidates with non-overlapping live ranges from the
2708         first list.  These are the Named Return Values.
2709
2710      4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
2711         Named Return Values in the function with the RESULT_DECL.
2712
2713    If the function returns an unconstrained type, things are a bit different
2714    because the anonymous return object is allocated on the secondary stack
2715    and RESULT_DECL is only a pointer to it.  Each return object can be of a
2716    different size and is allocated separately so we need not care about the
2717    aforementioned overlapping issues.  Therefore, we don't collect the other
2718    expressions and skip step #2 in the algorithm.  */
2719
2720 struct nrv_data
2721 {
2722   bitmap nrv;
2723   tree result;
2724   Node_Id gnat_ret;
2725   struct pointer_set_t *visited;
2726 };
2727
2728 /* Return true if T is a Named Return Value.  */
2729
2730 static inline bool
2731 is_nrv_p (bitmap nrv, tree t)
2732 {
2733   return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
2734 }
2735
2736 /* Helper function for walk_tree, used by finalize_nrv below.  */
2737
2738 static tree
2739 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
2740 {
2741   struct nrv_data *dp = (struct nrv_data *)data;
2742   tree t = *tp;
2743
2744   /* No need to walk into types or decls.  */
2745   if (IS_TYPE_OR_DECL_P (t))
2746     *walk_subtrees = 0;
2747
2748   if (is_nrv_p (dp->nrv, t))
2749     bitmap_clear_bit (dp->nrv, DECL_UID (t));
2750
2751   return NULL_TREE;
2752 }
2753
2754 /* Prune Named Return Values in BLOCK and return true if there is still a
2755    Named Return Value in BLOCK or one of its sub-blocks.  */
2756
2757 static bool
2758 prune_nrv_in_block (bitmap nrv, tree block)
2759 {
2760   bool has_nrv = false;
2761   tree t;
2762
2763   /* First recurse on the sub-blocks.  */
2764   for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
2765     has_nrv |= prune_nrv_in_block (nrv, t);
2766
2767   /* Then make sure to keep at most one NRV per block.  */
2768   for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
2769     if (is_nrv_p (nrv, t))
2770       {
2771         if (has_nrv)
2772           bitmap_clear_bit (nrv, DECL_UID (t));
2773         else
2774           has_nrv = true;
2775       }
2776
2777   return has_nrv;
2778 }
2779
2780 /* Helper function for walk_tree, used by finalize_nrv below.  */
2781
2782 static tree
2783 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
2784 {
2785   struct nrv_data *dp = (struct nrv_data *)data;
2786   tree t = *tp;
2787
2788   /* No need to walk into types.  */
2789   if (TYPE_P (t))
2790     *walk_subtrees = 0;
2791
2792   /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
2793      nop, but differs from using NULL_TREE in that it indicates that we care
2794      about the value of the RESULT_DECL.  */
2795   else if (TREE_CODE (t) == RETURN_EXPR
2796            && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
2797     {
2798       tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1), init_expr;
2799
2800       /* If this is the temporary created for a return value with variable
2801          size in call_to_gnu, we replace the RHS with the init expression.  */
2802       if (TREE_CODE (ret_val) == COMPOUND_EXPR
2803           && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
2804           && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
2805              == TREE_OPERAND (ret_val, 1))
2806         {
2807           init_expr = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
2808           ret_val = TREE_OPERAND (ret_val, 1);
2809         }
2810       else
2811         init_expr = NULL_TREE;
2812
2813       /* Strip useless conversions around the return value.  */
2814       if (gnat_useless_type_conversion (ret_val))
2815         ret_val = TREE_OPERAND (ret_val, 0);
2816
2817       if (is_nrv_p (dp->nrv, ret_val))
2818         {
2819           if (init_expr)
2820             TREE_OPERAND (TREE_OPERAND (t, 0), 1) = init_expr;
2821           else
2822             TREE_OPERAND (t, 0) = dp->result;
2823         }
2824     }
2825
2826   /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
2827      if needed.  */
2828   else if (TREE_CODE (t) == DECL_EXPR
2829            && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
2830     {
2831       tree var = DECL_EXPR_DECL (t), init;
2832
2833       if (DECL_INITIAL (var))
2834         {
2835           init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
2836                                   DECL_INITIAL (var));
2837           SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
2838           DECL_INITIAL (var) = NULL_TREE;
2839         }
2840       else
2841         init = build_empty_stmt (EXPR_LOCATION (t));
2842       *tp = init;
2843
2844       /* Identify the NRV to the RESULT_DECL for debugging purposes.  */
2845       SET_DECL_VALUE_EXPR (var, dp->result);
2846       DECL_HAS_VALUE_EXPR_P (var) = 1;
2847       /* ??? Kludge to avoid an assertion failure during inlining.  */
2848       DECL_SIZE (var) = bitsize_unit_node;
2849       DECL_SIZE_UNIT (var) = size_one_node;
2850     }
2851
2852   /* And replace all uses of NRVs with the RESULT_DECL.  */
2853   else if (is_nrv_p (dp->nrv, t))
2854     *tp = convert (TREE_TYPE (t), dp->result);
2855
2856   /* Avoid walking into the same tree more than once.  Unfortunately, we
2857      can't just use walk_tree_without_duplicates because it would only
2858      call us for the first occurrence of NRVs in the function body.  */
2859   if (pointer_set_insert (dp->visited, *tp))
2860     *walk_subtrees = 0;
2861
2862   return NULL_TREE;
2863 }
2864
2865 /* Likewise, but used when the function returns an unconstrained type.  */
2866
2867 static tree
2868 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
2869 {
2870   struct nrv_data *dp = (struct nrv_data *)data;
2871   tree t = *tp;
2872
2873   /* No need to walk into types.  */
2874   if (TYPE_P (t))
2875     *walk_subtrees = 0;
2876
2877   /* We need to see the DECL_EXPR of NRVs before any other references so we
2878      walk the body of BIND_EXPR before walking its variables.  */
2879   else if (TREE_CODE (t) == BIND_EXPR)
2880     walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
2881
2882   /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
2883      return value built by the allocator instead of the whole construct.  */
2884   else if (TREE_CODE (t) == RETURN_EXPR
2885            && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
2886     {
2887       tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
2888
2889       /* This is the construct returned by the allocator.  */
2890       if (TREE_CODE (ret_val) == COMPOUND_EXPR
2891           && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
2892         {
2893           if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
2894             ret_val
2895               = VEC_index (constructor_elt,
2896                            CONSTRUCTOR_ELTS
2897                            (TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1)),
2898                             1)->value;
2899           else
2900             ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
2901         }
2902
2903       /* Strip useless conversions around the return value.  */
2904       if (gnat_useless_type_conversion (ret_val)
2905           || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
2906         ret_val = TREE_OPERAND (ret_val, 0);
2907
2908       /* Strip unpadding around the return value.  */
2909       if (TREE_CODE (ret_val) == COMPONENT_REF
2910           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
2911         ret_val = TREE_OPERAND (ret_val, 0);
2912
2913       /* Assign the new return value to the RESULT_DECL.  */
2914       if (is_nrv_p (dp->nrv, ret_val))
2915         TREE_OPERAND (TREE_OPERAND (t, 0), 1)
2916           = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
2917     }
2918
2919   /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
2920      into a new variable.  */
2921   else if (TREE_CODE (t) == DECL_EXPR
2922            && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
2923     {
2924       tree saved_current_function_decl = current_function_decl;
2925       tree var = DECL_EXPR_DECL (t);
2926       tree alloc, p_array, new_var, new_ret;
2927       VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
2928
2929       /* Create an artificial context to build the allocation.  */
2930       current_function_decl = decl_function_context (var);
2931       start_stmt_group ();
2932       gnat_pushlevel ();
2933
2934       /* This will return a COMPOUND_EXPR with the allocation in the first
2935          arm and the final return value in the second arm.  */
2936       alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
2937                                TREE_TYPE (dp->result),
2938                                Procedure_To_Call (dp->gnat_ret),
2939                                Storage_Pool (dp->gnat_ret),
2940                                Empty, false);
2941
2942       /* The new variable is built as a reference to the allocated space.  */
2943       new_var
2944         = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
2945                       build_reference_type (TREE_TYPE (var)));
2946       DECL_BY_REFERENCE (new_var) = 1;
2947
2948       if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
2949         {
2950           /* The new initial value is a COMPOUND_EXPR with the allocation in
2951              the first arm and the value of P_ARRAY in the second arm.  */
2952           DECL_INITIAL (new_var)
2953             = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
2954                       TREE_OPERAND (alloc, 0),
2955                       VEC_index (constructor_elt,
2956                                  CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)),
2957                                                    0)->value);
2958
2959           /* Build a modified CONSTRUCTOR that references NEW_VAR.  */
2960           p_array = TYPE_FIELDS (TREE_TYPE (alloc));
2961           CONSTRUCTOR_APPEND_ELT (v, p_array,
2962                                   fold_convert (TREE_TYPE (p_array), new_var));
2963           CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
2964                                   VEC_index (constructor_elt,
2965                                              CONSTRUCTOR_ELTS
2966                                              (TREE_OPERAND (alloc, 1)),
2967                                               1)->value);
2968           new_ret = build_constructor (TREE_TYPE (alloc), v);
2969         }
2970       else
2971         {
2972           /* The new initial value is just the allocation.  */
2973           DECL_INITIAL (new_var) = alloc;
2974           new_ret = fold_convert (TREE_TYPE (alloc), new_var);
2975         }
2976
2977       gnat_pushdecl (new_var, Empty);
2978
2979       /* Destroy the artificial context and insert the new statements.  */
2980       gnat_zaplevel ();
2981       *tp = end_stmt_group ();
2982       current_function_decl = saved_current_function_decl;
2983
2984       /* Chain NEW_VAR immediately after VAR and ignore the latter.  */
2985       DECL_CHAIN (new_var) = DECL_CHAIN (var);
2986       DECL_CHAIN (var) = new_var;
2987       DECL_IGNORED_P (var) = 1;
2988
2989       /* Save the new return value and the dereference of NEW_VAR.  */
2990       DECL_INITIAL (var)
2991         = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
2992                   build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
2993       /* ??? Kludge to avoid messing up during inlining.  */
2994       DECL_CONTEXT (var) = NULL_TREE;
2995     }
2996
2997   /* And replace all uses of NRVs with the dereference of NEW_VAR.  */
2998   else if (is_nrv_p (dp->nrv, t))
2999     *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3000
3001   /* Avoid walking into the same tree more than once.  Unfortunately, we
3002      can't just use walk_tree_without_duplicates because it would only
3003      call us for the first occurrence of NRVs in the function body.  */
3004   if (pointer_set_insert (dp->visited, *tp))
3005     *walk_subtrees = 0;
3006
3007   return NULL_TREE;
3008 }
3009
3010 /* Finalize the Named Return Value optimization for FNDECL.  The NRV bitmap
3011    contains the candidates for Named Return Value and OTHER is a list of
3012    the other return values.  GNAT_RET is a representative return node.  */
3013
3014 static void
3015 finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other, Node_Id gnat_ret)
3016 {
3017   struct cgraph_node *node;
3018   struct nrv_data data;
3019   walk_tree_fn func;
3020   unsigned int i;
3021   tree iter;
3022
3023   /* We shouldn't be applying the optimization to return types that we aren't
3024      allowed to manipulate freely.  */
3025   gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3026
3027   /* Prune the candidates that are referenced by other return values.  */
3028   data.nrv = nrv;
3029   data.result = NULL_TREE;
3030   data.visited = NULL;
3031   for (i = 0; VEC_iterate(tree, other, i, iter); i++)
3032     walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3033   if (bitmap_empty_p (nrv))
3034     return;
3035
3036   /* Prune also the candidates that are referenced by nested functions.  */
3037   node = cgraph_get_create_node (fndecl);
3038   for (node = node->nested; node; node = node->next_nested)
3039     walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r,
3040                                   &data);
3041   if (bitmap_empty_p (nrv))
3042     return;
3043
3044   /* Extract a set of NRVs with non-overlapping live ranges.  */
3045   if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3046     return;
3047
3048   /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs.  */
3049   data.nrv = nrv;
3050   data.result = DECL_RESULT (fndecl);
3051   data.gnat_ret = gnat_ret;
3052   data.visited = pointer_set_create ();
3053   if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3054     func = finalize_nrv_unc_r;
3055   else
3056     func = finalize_nrv_r;
3057   walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3058   pointer_set_destroy (data.visited);
3059 }
3060
3061 /* Return true if RET_VAL can be used as a Named Return Value for the
3062    anonymous return object RET_OBJ.  */
3063
3064 static bool
3065 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3066 {
3067   if (TREE_CODE (ret_val) != VAR_DECL)
3068     return false;
3069
3070   if (TREE_THIS_VOLATILE (ret_val))
3071     return false;
3072
3073   if (DECL_CONTEXT (ret_val) != current_function_decl)
3074     return false;
3075
3076   if (TREE_STATIC (ret_val))
3077     return false;
3078
3079   if (TREE_ADDRESSABLE (ret_val))
3080     return false;
3081
3082   if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3083     return false;
3084
3085   return true;
3086 }
3087
3088 /* Build a RETURN_EXPR.  If RET_VAL is non-null, build a RETURN_EXPR around
3089    the assignment of RET_VAL to RET_OBJ.  Otherwise build a bare RETURN_EXPR
3090    around RESULT_OBJ, which may be null in this case.  */
3091
3092 static tree
3093 build_return_expr (tree ret_obj, tree ret_val)
3094 {
3095   tree result_expr;
3096
3097   if (ret_val)
3098     {
3099       /* The gimplifier explicitly enforces the following invariant:
3100
3101               RETURN_EXPR
3102                   |
3103               MODIFY_EXPR
3104               /        \
3105              /          \
3106          RET_OBJ        ...
3107
3108          As a consequence, type consistency dictates that we use the type
3109          of the RET_OBJ as the operation type.  */
3110       tree operation_type = TREE_TYPE (ret_obj);
3111
3112       /* Convert the right operand to the operation type.  Note that it's the
3113          same transformation as in the MODIFY_EXPR case of build_binary_op,
3114          with the assumption that the type cannot involve a placeholder.  */
3115       if (operation_type != TREE_TYPE (ret_val))
3116         ret_val = convert (operation_type, ret_val);
3117
3118       result_expr = build2 (MODIFY_EXPR, void_type_node, ret_obj, ret_val);
3119
3120       /* If the function returns an aggregate type, find out whether this is
3121          a candidate for Named Return Value.  If so, record it.  Otherwise,
3122          if this is an expression of some kind, record it elsewhere.  */
3123       if (optimize
3124           && AGGREGATE_TYPE_P (operation_type)
3125           && !TYPE_IS_FAT_POINTER_P (operation_type)
3126           && aggregate_value_p (operation_type, current_function_decl))
3127         {
3128           /* Recognize the temporary created for a return value with variable
3129              size in call_to_gnu.  We want to eliminate it if possible.  */
3130           if (TREE_CODE (ret_val) == COMPOUND_EXPR
3131               && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3132               && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3133                  == TREE_OPERAND (ret_val, 1))
3134             ret_val = TREE_OPERAND (ret_val, 1);
3135
3136           /* Strip useless conversions around the return value.  */
3137           if (gnat_useless_type_conversion (ret_val))
3138             ret_val = TREE_OPERAND (ret_val, 0);
3139
3140           /* Now apply the test to the return value.  */
3141           if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3142             {
3143               if (!f_named_ret_val)
3144                 f_named_ret_val = BITMAP_GGC_ALLOC ();
3145               bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3146             }
3147
3148           /* Note that we need not care about CONSTRUCTORs here, as they are
3149              totally transparent given the read-compose-write semantics of
3150              assignments from CONSTRUCTORs.  */
3151           else if (EXPR_P (ret_val))
3152             VEC_safe_push (tree, gc, f_other_ret_val, ret_val);
3153         }
3154     }
3155   else
3156     result_expr = ret_obj;
3157
3158   return build1 (RETURN_EXPR, void_type_node, result_expr);
3159 }
3160
3161 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
3162    and the GNAT node GNAT_SUBPROG.  */
3163
3164 static void
3165 build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
3166 {
3167   tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
3168   tree gnu_subprog_param, gnu_stub_param, gnu_param;
3169   tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
3170   VEC(tree,gc) *gnu_param_vec = NULL;
3171
3172   gnu_subprog_type = TREE_TYPE (gnu_subprog);
3173
3174   /* Initialize the information structure for the function.  */
3175   allocate_struct_function (gnu_stub_decl, false);
3176   set_cfun (NULL);
3177
3178   begin_subprog_body (gnu_stub_decl);
3179
3180   start_stmt_group ();
3181   gnat_pushlevel ();
3182
3183   /* Loop over the parameters of the stub and translate any of them
3184      passed by descriptor into a by reference one.  */
3185   for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
3186        gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog);