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
2406                   = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1);
2407               else
2408                 gnu_base_type = size_type_node;
2409
2410               gnu_first = convert (gnu_base_type, gnu_first);
2411               gnu_last = convert (gnu_base_type, gnu_last);
2412               gnu_one_node = convert (gnu_base_type, integer_one_node);
2413               use_iv = true;
2414             }
2415
2416           gnu_first
2417             = build_binary_op (shift_code, gnu_base_type, gnu_first,
2418                                gnu_one_node);
2419           LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2420           LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2421         }
2422       else
2423         {
2424           /* We can use the default form if GNU_LAST+1 doesn't overflow.  */
2425           if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2426             ;
2427
2428           /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2429              GNU_LAST-1 does.  */
2430           else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2431                    && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2432             {
2433               gnu_first
2434                 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2435                                    gnu_one_node);
2436               gnu_last
2437                 = build_binary_op (shift_code, gnu_base_type, gnu_last,
2438                                    gnu_one_node);
2439               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2440             }
2441
2442           /* Otherwise, use the fallback form.  */
2443           else
2444             LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2445         }
2446
2447       /* If we use the BOTTOM_COND, we can turn the test into an inequality
2448          test but we may have to add ENTRY_COND to protect the empty loop.  */
2449       if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2450         {
2451           test_code = NE_EXPR;
2452           if (can_be_lower_p (gnu_high, gnu_low))
2453             {
2454               gnu_cond_expr
2455                 = build3 (COND_EXPR, void_type_node,
2456                           build_binary_op (LE_EXPR, boolean_type_node,
2457                                            gnu_low, gnu_high),
2458                           NULL_TREE, alloc_stmt_list ());
2459               set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2460             }
2461         }
2462
2463       /* Open a new nesting level that will surround the loop to declare the
2464          iteration variable.  */
2465       start_stmt_group ();
2466       gnat_pushlevel ();
2467
2468       /* If we use the special induction variable, create it and set it to
2469          its initial value.  Morever, the regular iteration variable cannot
2470          itself be initialized, lest the initial value wrapped around.  */
2471       if (use_iv)
2472         {
2473           gnu_loop_iv
2474             = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
2475           add_stmt (gnu_stmt);
2476           gnu_first = NULL_TREE;
2477         }
2478       else
2479         gnu_loop_iv = NULL_TREE;
2480
2481       /* Declare the iteration variable and set it to its initial value.  */
2482       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2483       if (DECL_BY_REF_P (gnu_loop_var))
2484         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2485       else if (use_iv)
2486         {
2487           gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
2488           SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
2489         }
2490       gnu_loop_info->loop_var = gnu_loop_var;
2491
2492       /* Do all the arithmetics in the base type.  */
2493       gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2494
2495       /* Set either the top or bottom exit condition.  */
2496       if (use_iv)
2497         LOOP_STMT_COND (gnu_loop_stmt)
2498           = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
2499                              gnu_last);
2500       else
2501         LOOP_STMT_COND (gnu_loop_stmt)
2502           = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2503                              gnu_last);
2504
2505       /* Set either the top or bottom update statement and give it the source
2506          location of the iteration for better coverage info.  */
2507       if (use_iv)
2508         {
2509           gnu_stmt
2510             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
2511                                build_binary_op (update_code, gnu_base_type,
2512                                                 gnu_loop_iv, gnu_one_node));
2513           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2514           append_to_statement_list (gnu_stmt,
2515                                     &LOOP_STMT_UPDATE (gnu_loop_stmt));
2516           gnu_stmt
2517             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2518                                gnu_loop_iv);
2519           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2520           append_to_statement_list (gnu_stmt,
2521                                     &LOOP_STMT_UPDATE (gnu_loop_stmt));
2522         }
2523       else
2524         {
2525           gnu_stmt
2526             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2527                                build_binary_op (update_code, gnu_base_type,
2528                                                 gnu_loop_var, gnu_one_node));
2529           set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2530           LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
2531         }
2532     }
2533
2534   /* If the loop was named, have the name point to this loop.  In this case,
2535      the association is not a DECL node, but the end label of the loop.  */
2536   if (Present (Identifier (gnat_node)))
2537     save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2538
2539   /* Make the loop body into its own block, so any allocated storage will be
2540      released every iteration.  This is needed for stack allocation.  */
2541   LOOP_STMT_BODY (gnu_loop_stmt)
2542     = build_stmt_group (Statements (gnat_node), true);
2543   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2544
2545   /* If we have an iteration scheme, then we are in a statement group.  Add
2546      the LOOP_STMT to it, finish it and make it the "loop".  */
2547   if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
2548     {
2549       struct range_check_info_d *rci;
2550       unsigned n_checks = VEC_length (range_check_info, gnu_loop_info->checks);
2551       unsigned int i;
2552
2553       /* First, if we have computed a small number of invariant conditions for
2554          range checks applied to the iteration variable, then initialize these
2555          conditions in front of the loop.  Otherwise, leave them set to True.
2556
2557          ??? The heuristics need to be improved, by taking into account the
2558              following datapoints:
2559                - loop unswitching is disabled for big loops.  The cap is the
2560                  parameter PARAM_MAX_UNSWITCH_INSNS (50).
2561                - loop unswitching can only be applied a small number of times
2562                  to a given loop.  The cap is PARAM_MAX_UNSWITCH_LEVEL (3).
2563                - the front-end quickly generates useless or redundant checks
2564                  that can be entirely optimized away in the end.  */
2565       if (1 <= n_checks && n_checks <= 4)
2566         for (i = 0;
2567              VEC_iterate (range_check_info, gnu_loop_info->checks, i, rci);
2568              i++)
2569           {
2570             tree low_ok
2571               = build_binary_op (GE_EXPR, boolean_type_node,
2572                                  convert (rci->type, gnu_low),
2573                                  rci->low_bound);
2574             tree high_ok
2575               = build_binary_op (LE_EXPR, boolean_type_node,
2576                                  convert (rci->type, gnu_high),
2577                                  rci->high_bound);
2578             tree range_ok
2579               = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
2580                                  low_ok, high_ok);
2581
2582             TREE_OPERAND (rci->invariant_cond, 0)
2583               = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
2584
2585             add_stmt_with_node_force (rci->invariant_cond, gnat_node);
2586           }
2587
2588       add_stmt (gnu_loop_stmt);
2589       gnat_poplevel ();
2590       gnu_loop_stmt = end_stmt_group ();
2591     }
2592
2593   /* If we have an outer COND_EXPR, that's our result and this loop is its
2594      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2595   if (gnu_cond_expr)
2596     {
2597       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2598       gnu_result = gnu_cond_expr;
2599       recalculate_side_effects (gnu_cond_expr);
2600     }
2601   else
2602     gnu_result = gnu_loop_stmt;
2603
2604   VEC_pop (loop_info, gnu_loop_stack);
2605
2606   return gnu_result;
2607 }
2608 \f
2609 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2610    handler for the current function.  */
2611
2612 /* This is implemented by issuing a call to the appropriate VMS specific
2613    builtin.  To avoid having VMS specific sections in the global gigi decls
2614    array, we maintain the decls of interest here.  We can't declare them
2615    inside the function because we must mark them never to be GC'd, which we
2616    can only do at the global level.  */
2617
2618 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2619 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2620
2621 static void
2622 establish_gnat_vms_condition_handler (void)
2623 {
2624   tree establish_stmt;
2625
2626   /* Elaborate the required decls on the first call.  Check on the decl for
2627      the gnat condition handler to decide, as this is one we create so we are
2628      sure that it will be non null on subsequent calls.  The builtin decl is
2629      looked up so remains null on targets where it is not implemented yet.  */
2630   if (gnat_vms_condition_handler_decl == NULL_TREE)
2631     {
2632       vms_builtin_establish_handler_decl
2633         = builtin_decl_for
2634           (get_identifier ("__builtin_establish_vms_condition_handler"));
2635
2636       gnat_vms_condition_handler_decl
2637         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2638                                NULL_TREE,
2639                                build_function_type_list (boolean_type_node,
2640                                                          ptr_void_type_node,
2641                                                          ptr_void_type_node,
2642                                                          NULL_TREE),
2643                                NULL_TREE, false, true, true, true, NULL,
2644                                Empty);
2645
2646       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2647       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2648     }
2649
2650   /* Do nothing if the establish builtin is not available, which might happen
2651      on targets where the facility is not implemented.  */
2652   if (vms_builtin_establish_handler_decl == NULL_TREE)
2653     return;
2654
2655   establish_stmt
2656     = build_call_n_expr (vms_builtin_establish_handler_decl, 1,
2657                          build_unary_op
2658                          (ADDR_EXPR, NULL_TREE,
2659                           gnat_vms_condition_handler_decl));
2660
2661   add_stmt (establish_stmt);
2662 }
2663
2664 /* This page implements a form of Named Return Value optimization modelled
2665    on the C++ optimization of the same name.  The main difference is that
2666    we disregard any semantical considerations when applying it here, the
2667    counterpart being that we don't try to apply it to semantically loaded
2668    return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
2669
2670    We consider a function body of the following GENERIC form:
2671
2672      return_type R1;
2673        [...]
2674      RETURN_EXPR [<retval> = ...]
2675        [...]
2676      RETURN_EXPR [<retval> = R1]
2677        [...]
2678      return_type Ri;
2679        [...]
2680      RETURN_EXPR [<retval> = ...]
2681        [...]
2682      RETURN_EXPR [<retval> = Ri]
2683        [...]
2684
2685    and we try to fulfill a simple criterion that would make it possible to
2686    replace one or several Ri variables with the RESULT_DECL of the function.
2687
2688    The first observation is that RETURN_EXPRs that don't directly reference
2689    any of the Ri variables on the RHS of their assignment are transparent wrt
2690    the optimization.  This is because the Ri variables aren't addressable so
2691    any transformation applied to them doesn't affect the RHS; moreover, the
2692    assignment writes the full <retval> object so existing values are entirely
2693    discarded.
2694
2695    This property can be extended to some forms of RETURN_EXPRs that reference
2696    the Ri variables, for example CONSTRUCTORs, but isn't true in the general
2697    case, in particular when function calls are involved.
2698
2699    Therefore the algorithm is as follows:
2700
2701      1. Collect the list of candidates for a Named Return Value (Ri variables
2702         on the RHS of assignments of RETURN_EXPRs) as well as the list of the
2703         other expressions on the RHS of such assignments.
2704
2705      2. Prune the members of the first list (candidates) that are referenced
2706         by a member of the second list (expressions).
2707
2708      3. Extract a set of candidates with non-overlapping live ranges from the
2709         first list.  These are the Named Return Values.
2710
2711      4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
2712         Named Return Values in the function with the RESULT_DECL.
2713
2714    If the function returns an unconstrained type, things are a bit different
2715    because the anonymous return object is allocated on the secondary stack
2716    and RESULT_DECL is only a pointer to it.  Each return object can be of a
2717    different size and is allocated separately so we need not care about the
2718    aforementioned overlapping issues.  Therefore, we don't collect the other
2719    expressions and skip step #2 in the algorithm.  */
2720
2721 struct nrv_data
2722 {
2723   bitmap nrv;
2724   tree result;
2725   Node_Id gnat_ret;
2726   struct pointer_set_t *visited;
2727 };
2728
2729 /* Return true if T is a Named Return Value.  */
2730
2731 static inline bool
2732 is_nrv_p (bitmap nrv, tree t)
2733 {
2734   return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
2735 }
2736
2737 /* Helper function for walk_tree, used by finalize_nrv below.  */
2738
2739 static tree
2740 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
2741 {
2742   struct nrv_data *dp = (struct nrv_data *)data;
2743   tree t = *tp;
2744
2745   /* No need to walk into types or decls.  */
2746   if (IS_TYPE_OR_DECL_P (t))
2747     *walk_subtrees = 0;
2748
2749   if (is_nrv_p (dp->nrv, t))
2750     bitmap_clear_bit (dp->nrv, DECL_UID (t));
2751
2752   return NULL_TREE;
2753 }
2754
2755 /* Prune Named Return Values in BLOCK and return true if there is still a
2756    Named Return Value in BLOCK or one of its sub-blocks.  */
2757
2758 static bool
2759 prune_nrv_in_block (bitmap nrv, tree block)
2760 {
2761   bool has_nrv = false;
2762   tree t;
2763
2764   /* First recurse on the sub-blocks.  */
2765   for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
2766     has_nrv |= prune_nrv_in_block (nrv, t);
2767
2768   /* Then make sure to keep at most one NRV per block.  */
2769   for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
2770     if (is_nrv_p (nrv, t))
2771       {
2772         if (has_nrv)
2773           bitmap_clear_bit (nrv, DECL_UID (t));
2774         else
2775           has_nrv = true;
2776       }
2777
2778   return has_nrv;
2779 }
2780
2781 /* Helper function for walk_tree, used by finalize_nrv below.  */
2782
2783 static tree
2784 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
2785 {
2786   struct nrv_data *dp = (struct nrv_data *)data;
2787   tree t = *tp;
2788
2789   /* No need to walk into types.  */
2790   if (TYPE_P (t))
2791     *walk_subtrees = 0;
2792
2793   /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
2794      nop, but differs from using NULL_TREE in that it indicates that we care
2795      about the value of the RESULT_DECL.  */
2796   else if (TREE_CODE (t) == RETURN_EXPR
2797            && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
2798     {
2799       tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1), init_expr;
2800
2801       /* If this is the temporary created for a return value with variable
2802          size in call_to_gnu, we replace the RHS with the init expression.  */
2803       if (TREE_CODE (ret_val) == COMPOUND_EXPR
2804           && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
2805           && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
2806              == TREE_OPERAND (ret_val, 1))
2807         {
2808           init_expr = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
2809           ret_val = TREE_OPERAND (ret_val, 1);
2810         }
2811       else
2812         init_expr = NULL_TREE;
2813
2814       /* Strip useless conversions around the return value.  */
2815       if (gnat_useless_type_conversion (ret_val))
2816         ret_val = TREE_OPERAND (ret_val, 0);
2817
2818       if (is_nrv_p (dp->nrv, ret_val))
2819         {
2820           if (init_expr)
2821             TREE_OPERAND (TREE_OPERAND (t, 0), 1) = init_expr;
2822           else
2823             TREE_OPERAND (t, 0) = dp->result;
2824         }
2825     }
2826
2827   /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
2828      if needed.  */
2829   else if (TREE_CODE (t) == DECL_EXPR
2830            && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
2831     {
2832       tree var = DECL_EXPR_DECL (t), init;
2833
2834       if (DECL_INITIAL (var))
2835         {
2836           init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
2837                                   DECL_INITIAL (var));
2838           SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
2839           DECL_INITIAL (var) = NULL_TREE;
2840         }
2841       else
2842         init = build_empty_stmt (EXPR_LOCATION (t));
2843       *tp = init;
2844
2845       /* Identify the NRV to the RESULT_DECL for debugging purposes.  */
2846       SET_DECL_VALUE_EXPR (var, dp->result);
2847       DECL_HAS_VALUE_EXPR_P (var) = 1;
2848       /* ??? Kludge to avoid an assertion failure during inlining.  */
2849       DECL_SIZE (var) = bitsize_unit_node;
2850       DECL_SIZE_UNIT (var) = size_one_node;
2851     }
2852
2853   /* And replace all uses of NRVs with the RESULT_DECL.  */
2854   else if (is_nrv_p (dp->nrv, t))
2855     *tp = convert (TREE_TYPE (t), dp->result);
2856
2857   /* Avoid walking into the same tree more than once.  Unfortunately, we
2858      can't just use walk_tree_without_duplicates because it would only
2859      call us for the first occurrence of NRVs in the function body.  */
2860   if (pointer_set_insert (dp->visited, *tp))
2861     *walk_subtrees = 0;
2862
2863   return NULL_TREE;
2864 }
2865
2866 /* Likewise, but used when the function returns an unconstrained type.  */
2867
2868 static tree
2869 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
2870 {
2871   struct nrv_data *dp = (struct nrv_data *)data;
2872   tree t = *tp;
2873
2874   /* No need to walk into types.  */
2875   if (TYPE_P (t))
2876     *walk_subtrees = 0;
2877
2878   /* We need to see the DECL_EXPR of NRVs before any other references so we
2879      walk the body of BIND_EXPR before walking its variables.  */
2880   else if (TREE_CODE (t) == BIND_EXPR)
2881     walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
2882
2883   /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
2884      return value built by the allocator instead of the whole construct.  */
2885   else if (TREE_CODE (t) == RETURN_EXPR
2886            && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
2887     {
2888       tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
2889
2890       /* This is the construct returned by the allocator.  */
2891       if (TREE_CODE (ret_val) == COMPOUND_EXPR
2892           && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
2893         {
2894           if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
2895             ret_val
2896               = VEC_index (constructor_elt,
2897                            CONSTRUCTOR_ELTS
2898                            (TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1)),
2899                             1)->value;
2900           else
2901             ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
2902         }
2903
2904       /* Strip useless conversions around the return value.  */
2905       if (gnat_useless_type_conversion (ret_val)
2906           || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
2907         ret_val = TREE_OPERAND (ret_val, 0);
2908
2909       /* Strip unpadding around the return value.  */
2910       if (TREE_CODE (ret_val) == COMPONENT_REF
2911           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
2912         ret_val = TREE_OPERAND (ret_val, 0);
2913
2914       /* Assign the new return value to the RESULT_DECL.  */
2915       if (is_nrv_p (dp->nrv, ret_val))
2916         TREE_OPERAND (TREE_OPERAND (t, 0), 1)
2917           = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
2918     }
2919
2920   /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
2921      into a new variable.  */
2922   else if (TREE_CODE (t) == DECL_EXPR
2923            && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
2924     {
2925       tree saved_current_function_decl = current_function_decl;
2926       tree var = DECL_EXPR_DECL (t);
2927       tree alloc, p_array, new_var, new_ret;
2928       VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
2929
2930       /* Create an artificial context to build the allocation.  */
2931       current_function_decl = decl_function_context (var);
2932       start_stmt_group ();
2933       gnat_pushlevel ();
2934
2935       /* This will return a COMPOUND_EXPR with the allocation in the first
2936          arm and the final return value in the second arm.  */
2937       alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
2938                                TREE_TYPE (dp->result),
2939                                Procedure_To_Call (dp->gnat_ret),
2940                                Storage_Pool (dp->gnat_ret),
2941                                Empty, false);
2942
2943       /* The new variable is built as a reference to the allocated space.  */
2944       new_var
2945         = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
2946                       build_reference_type (TREE_TYPE (var)));
2947       DECL_BY_REFERENCE (new_var) = 1;
2948
2949       if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
2950         {
2951           /* The new initial value is a COMPOUND_EXPR with the allocation in
2952              the first arm and the value of P_ARRAY in the second arm.  */
2953           DECL_INITIAL (new_var)
2954             = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
2955                       TREE_OPERAND (alloc, 0),
2956                       VEC_index (constructor_elt,
2957                                  CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)),
2958                                                    0)->value);
2959
2960           /* Build a modified CONSTRUCTOR that references NEW_VAR.  */
2961           p_array = TYPE_FIELDS (TREE_TYPE (alloc));
2962           CONSTRUCTOR_APPEND_ELT (v, p_array,
2963                                   fold_convert (TREE_TYPE (p_array), new_var));
2964           CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
2965                                   VEC_index (constructor_elt,
2966                                              CONSTRUCTOR_ELTS
2967                                              (TREE_OPERAND (alloc, 1)),
2968                                               1)->value);
2969           new_ret = build_constructor (TREE_TYPE (alloc), v);
2970         }
2971       else
2972         {
2973           /* The new initial value is just the allocation.  */
2974           DECL_INITIAL (new_var) = alloc;
2975           new_ret = fold_convert (TREE_TYPE (alloc), new_var);
2976         }
2977
2978       gnat_pushdecl (new_var, Empty);
2979
2980       /* Destroy the artificial context and insert the new statements.  */
2981       gnat_zaplevel ();
2982       *tp = end_stmt_group ();
2983       current_function_decl = saved_current_function_decl;
2984
2985       /* Chain NEW_VAR immediately after VAR and ignore the latter.  */
2986       DECL_CHAIN (new_var) = DECL_CHAIN (var);
2987       DECL_CHAIN (var) = new_var;
2988       DECL_IGNORED_P (var) = 1;
2989
2990       /* Save the new return value and the dereference of NEW_VAR.  */
2991       DECL_INITIAL (var)
2992         = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
2993                   build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
2994       /* ??? Kludge to avoid messing up during inlining.  */
2995       DECL_CONTEXT (var) = NULL_TREE;
2996     }
2997
2998   /* And replace all uses of NRVs with the dereference of NEW_VAR.  */
2999   else if (is_nrv_p (dp->nrv, t))
3000     *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3001
3002   /* Avoid walking into the same tree more than once.  Unfortunately, we
3003      can't just use walk_tree_without_duplicates because it would only
3004      call us for the first occurrence of NRVs in the function body.  */
3005   if (pointer_set_insert (dp->visited, *tp))
3006     *walk_subtrees = 0;
3007
3008   return NULL_TREE;
3009 }
3010
3011 /* Finalize the Named Return Value optimization for FNDECL.  The NRV bitmap
3012    contains the candidates for Named Return Value and OTHER is a list of
3013    the other return values.  GNAT_RET is a representative return node.  */
3014
3015 static void
3016 finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other, Node_Id gnat_ret)
3017 {
3018   struct cgraph_node *node;
3019   struct nrv_data data;
3020   walk_tree_fn func;
3021   unsigned int i;
3022   tree iter;
3023
3024   /* We shouldn't be applying the optimization to return types that we aren't
3025      allowed to manipulate freely.  */
3026   gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3027
3028   /* Prune the candidates that are referenced by other return values.  */
3029   data.nrv = nrv;
3030   data.result = NULL_TREE;
3031   data.visited = NULL;
3032   for (i = 0; VEC_iterate(tree, other, i, iter); i++)
3033     walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3034   if (bitmap_empty_p (nrv))
3035     return;
3036
3037   /* Prune also the candidates that are referenced by nested functions.  */
3038   node = cgraph_get_create_node (fndecl);
3039   for (node = node->nested; node; node = node->next_nested)
3040     walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r,
3041                                   &data);
3042   if (bitmap_empty_p (nrv))
3043     return;
3044
3045   /* Extract a set of NRVs with non-overlapping live ranges.  */
3046   if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3047     return;
3048
3049   /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs.  */
3050   data.nrv = nrv;
3051   data.result = DECL_RESULT (fndecl);
3052   data.gnat_ret = gnat_ret;
3053   data.visited = pointer_set_create ();
3054   if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3055     func = finalize_nrv_unc_r;
3056   else
3057     func = finalize_nrv_r;
3058   walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3059   pointer_set_destroy (data.visited);
3060 }
3061
3062 /* Return true if RET_VAL can be used as a Named Return Value for the
3063    anonymous return object RET_OBJ.  */
3064
3065 static bool
3066 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3067 {
3068   if (TREE_CODE (ret_val) != VAR_DECL)
3069     return false;
3070
3071   if (TREE_THIS_VOLATILE (ret_val))
3072     return false;
3073
3074   if (DECL_CONTEXT (ret_val) != current_function_decl)
3075     return false;
3076
3077   if (TREE_STATIC (ret_val))
3078     return false;
3079
3080   if (TREE_ADDRESSABLE (ret_val))
3081     return false;
3082
3083   if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3084     return false;
3085
3086   return true;
3087 }
3088
3089 /* Build a RETURN_EXPR.  If RET_VAL is non-null, build a RETURN_EXPR around
3090    the assignment of RET_VAL to RET_OBJ.  Otherwise build a bare RETURN_EXPR
3091    around RESULT_OBJ, which may be null in this case.  */
3092
3093 static tree
3094 build_return_expr (tree ret_obj, tree ret_val)
3095 {
3096   tree result_expr;
3097
3098   if (ret_val)
3099     {
3100       /* The gimplifier explicitly enforces the following invariant:
3101
3102               RETURN_EXPR
3103                   |
3104               MODIFY_EXPR
3105               /        \
3106              /          \
3107          RET_OBJ        ...
3108
3109          As a consequence, type consistency dictates that we use the type
3110          of the RET_OBJ as the operation type.  */
3111       tree operation_type = TREE_TYPE (ret_obj);
3112
3113       /* Convert the right operand to the operation type.  Note that it's the
3114          same transformation as in the MODIFY_EXPR case of build_binary_op,
3115          with the assumption that the type cannot involve a placeholder.  */
3116       if (operation_type != TREE_TYPE (ret_val))
3117         ret_val = convert (operation_type, ret_val);
3118
3119       result_expr = build2 (MODIFY_EXPR, void_type_node, ret_obj, ret_val);
3120
3121       /* If the function returns an aggregate type, find out whether this is
3122          a candidate for Named Return Value.  If so, record it.  Otherwise,
3123          if this is an expression of some kind, record it elsewhere.  */
3124       if (optimize
3125           && AGGREGATE_TYPE_P (operation_type)
3126           && !TYPE_IS_FAT_POINTER_P (operation_type)
3127           && TYPE_MODE (operation_type) == BLKmode
3128           && aggregate_value_p (operation_type, current_function_decl))
3129         {
3130           /* Recognize the temporary created for a return value with variable
3131              size in call_to_gnu.  We want to eliminate it if possible.  */
3132           if (TREE_CODE (ret_val) == COMPOUND_EXPR
3133               && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3134               && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3135                  == TREE_OPERAND (ret_val, 1))
3136             ret_val = TREE_OPERAND (ret_val, 1);
3137
3138           /* Strip useless conversions around the return value.  */
3139           if (gnat_useless_type_conversion (ret_val))
3140             ret_val = TREE_OPERAND (ret_val, 0);
3141
3142           /* Now apply the test to the return value.  */
3143           if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3144             {
3145               if (!f_named_ret_val)
3146                 f_named_ret_val = BITMAP_GGC_ALLOC ();
3147               bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3148             }
3149
3150           /* Note that we need not care about CONSTRUCTORs here, as they are
3151              totally transparent given the read-compose-write semantics of
3152              assignments from CONSTRUCTORs.  */
3153           else if (EXPR_P (ret_val))
3154             VEC_safe_push (tree, gc, f_other_ret_val, ret_val);
3155         }
3156     }
3157   else
3158     result_expr = ret_obj;
3159
3160   return build1 (RETURN_EXPR, void_type_node, result_expr);
3161 }
3162
3163 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
3164    and the GNAT node GNAT_SUBPROG.  */
3165
3166 static void
3167 build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
3168 {
3169   tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
3170   tree gnu_subprog_param, gnu_stub_param, gnu_param;
3171   tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
3172   VEC(tree,gc) *gnu_param_vec = NULL;
3173
3174   gnu_subprog_type = TREE_TYPE (gnu_subprog);
3175
3176   /* Initialize the information structure for the function.  */
3177   allocate_struct_function (gnu_stub_decl, false);
3178   set_cfun (NULL);
3179
3180   begin_subprog_body (gnu_stub_decl);
3181
3182   start_stmt_group ();
3183   gnat_pushlevel ();
3184
3185   /* Loop over the parameters of the stub and translate any of them
3186      passed by descriptor into a by reference one.  */
3187   for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
3188        gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog);
3189        gnu_stub_param;
3190        gnu_stub_param = DECL_CHAIN (gnu_stub_param),
3191        gnu_subprog_param = DECL_CHAIN (gnu_subprog_param))
3192     {
3193       if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
3194         {
3195           gcc_assert (DECL_BY_REF_P (gnu_subprog_param));
3196           gnu_param
3197             = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param),
3198                                       gnu_stub_param,
3199                                       DECL_PARM_ALT_TYPE (gnu_stub_param),
3200                                       DECL_BY_DOUBLE_REF_P (gnu_subprog_param),
3201                                       gnat_subprog);
3202         }
3203       else
3204         gnu_param = gnu_stub_param;
3205
3206       VEC_safe_push (tree, gc, gnu_param_vec, gnu_param);
3207     }
3208
3209   /* Invoke the internal subprogram.  */
3210   gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
3211                              gnu_subprog);
3212   gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type),
3213                                      gnu_subprog_addr, gnu_param_vec);
3214
3215   /* Propagate the return value, if any.  */
3216   if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
3217     add_stmt (gnu_subprog_call);
3218   else
3219     add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl),
3220                                  gnu_subprog_call));
3221
3222   gnat_poplevel ();
3223   end_subprog_body (end_stmt_group ());
3224   rest_of_subprog_body_compilation (gnu_stub_decl);
3225 }
3226 \f
3227 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
3228    don't return anything.  */
3229
3230 static void
3231 Subprogram_Body_to_gnu (Node_Id gnat_node)
3232 {
3233   /* Defining identifier of a parameter to the subprogram.  */
3234   Entity_Id gnat_param;
3235   /* The defining identifier for the subprogram body. Note that if a
3236      specification has appeared before for this body, then the identifier
3237      occurring in that specification will also be a defining identifier and all
3238      the calls to this subprogram will point to that specification.  */
3239   Entity_Id gnat_subprog_id
3240     = (Present (Corresponding_Spec (gnat_node))
3241        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3242   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
3243   tree gnu_subprog_decl;
3244   /* Its RESULT_DECL node.  */
3245   tree gnu_result_decl;
3246   /* Its FUNCTION_TYPE node.  */
3247   tree gnu_subprog_type;
3248   /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any.  */
3249   tree gnu_cico_list;
3250   /* The entry in the CI_CO_LIST that represents a function return, if any.  */
3251   tree gnu_return_var_elmt = NULL_TREE;
3252   tree gnu_result;
3253   struct language_function *gnu_subprog_language;
3254   VEC(parm_attr,gc) *cache;
3255
3256   /* If this is a generic object or if it has been eliminated,
3257      ignore it.  */
3258   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
3259       || Ekind (gnat_subprog_id) == E_Generic_Function
3260       || Is_Eliminated (gnat_subprog_id))
3261     return;
3262
3263   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
3264      the already-elaborated tree node.  However, if this subprogram had its
3265      elaboration deferred, we will already have made a tree node for it.  So
3266      treat it as not being defined in that case.  Such a subprogram cannot
3267      have an address clause or a freeze node, so this test is safe, though it
3268      does disable some otherwise-useful error checking.  */
3269   gnu_subprog_decl
3270     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
3271                           Acts_As_Spec (gnat_node)
3272                           && !present_gnu_tree (gnat_subprog_id));
3273   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
3274   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
3275   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3276   if (gnu_cico_list)
3277     gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list);
3278
3279   /* If the function returns by invisible reference, make it explicit in the
3280      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.
3281      Handle the explicit case here and the copy-in/copy-out case below.  */
3282   if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt)
3283     {
3284       TREE_TYPE (gnu_result_decl)
3285         = build_reference_type (TREE_TYPE (gnu_result_decl));
3286       relayout_decl (gnu_result_decl);
3287     }
3288
3289   /* Set the line number in the decl to correspond to that of the body so that
3290      the line number notes are written correctly.  */
3291   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
3292
3293   /* Initialize the information structure for the function.  */
3294   allocate_struct_function (gnu_subprog_decl, false);
3295   gnu_subprog_language = ggc_alloc_cleared_language_function ();
3296   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
3297   set_cfun (NULL);
3298
3299   begin_subprog_body (gnu_subprog_decl);
3300
3301   /* If there are In Out or Out parameters, we need to ensure that the return
3302      statement properly copies them out.  We do this by making a new block and
3303      converting any return into a goto to a label at the end of the block.  */
3304   if (gnu_cico_list)
3305     {
3306       tree gnu_return_var = NULL_TREE;
3307
3308       VEC_safe_push (tree, gc, gnu_return_label_stack,
3309                      create_artificial_label (input_location));
3310
3311       start_stmt_group ();
3312       gnat_pushlevel ();
3313
3314       /* If this is a function with In Out or Out parameters, we also need a
3315          variable for the return value to be placed.  */
3316       if (gnu_return_var_elmt)
3317         {
3318           tree gnu_return_type
3319             = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3320
3321           /* If the function returns by invisible reference, make it
3322              explicit in the function body.  See gnat_to_gnu_entity,
3323              E_Subprogram_Type case.  */
3324           if (TREE_ADDRESSABLE (gnu_subprog_type))
3325             gnu_return_type = build_reference_type (gnu_return_type);
3326
3327           gnu_return_var
3328             = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3329                                gnu_return_type, NULL_TREE, false, false,
3330                                false, false, NULL, gnat_subprog_id);
3331           TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3332         }
3333
3334       VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var);
3335
3336       /* See whether there are parameters for which we don't have a GCC tree
3337          yet.  These must be Out parameters.  Make a VAR_DECL for them and
3338          put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3339          We can match up the entries because TYPE_CI_CO_LIST is in the order
3340          of the parameters.  */
3341       for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3342            Present (gnat_param);
3343            gnat_param = Next_Formal_With_Extras (gnat_param))
3344         if (!present_gnu_tree (gnat_param))
3345           {
3346             tree gnu_cico_entry = gnu_cico_list;
3347
3348             /* Skip any entries that have been already filled in; they must
3349                correspond to In Out parameters.  */
3350             while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3351               gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3352
3353             /* Do any needed references for padded types.  */
3354             TREE_VALUE (gnu_cico_entry)
3355               = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)),
3356                          gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
3357           }
3358     }
3359   else
3360     VEC_safe_push (tree, gc, gnu_return_label_stack, NULL_TREE);
3361
3362   /* Get a tree corresponding to the code for the subprogram.  */
3363   start_stmt_group ();
3364   gnat_pushlevel ();
3365
3366   /* On VMS, establish our condition handler to possibly turn a condition into
3367      the corresponding exception if the subprogram has a foreign convention or
3368      is exported.
3369
3370      To ensure proper execution of local finalizations on condition instances,
3371      we must turn a condition into the corresponding exception even if there
3372      is no applicable Ada handler, and need at least one condition handler per
3373      possible call chain involving GNAT code.  OTOH, establishing the handler
3374      has a cost so we want to minimize the number of subprograms into which
3375      this happens.  The foreign or exported condition is expected to satisfy
3376      all the constraints.  */
3377   if (TARGET_ABI_OPEN_VMS
3378       && (Has_Foreign_Convention (gnat_subprog_id)
3379           || Is_Exported (gnat_subprog_id)))
3380     establish_gnat_vms_condition_handler ();
3381
3382   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3383
3384   /* Generate the code of the subprogram itself.  A return statement will be
3385      present and any Out parameters will be handled there.  */
3386   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3387   gnat_poplevel ();
3388   gnu_result = end_stmt_group ();
3389
3390   /* If we populated the parameter attributes cache, we need to make sure that
3391      the cached expressions are evaluated on all the possible paths leading to
3392      their uses.  So we force their evaluation on entry of the function.  */
3393   cache = gnu_subprog_language->parm_attr_cache;
3394   if (cache)
3395     {
3396       struct parm_attr_d *pa;
3397       int i;
3398
3399       start_stmt_group ();
3400
3401       FOR_EACH_VEC_ELT (parm_attr, cache, i, pa)
3402         {
3403           if (pa->first)
3404             add_stmt_with_node_force (pa->first, gnat_node);
3405           if (pa->last)
3406             add_stmt_with_node_force (pa->last, gnat_node);
3407           if (pa->length)
3408             add_stmt_with_node_force (pa->length, gnat_node);
3409         }
3410
3411       add_stmt (gnu_result);
3412       gnu_result = end_stmt_group ();
3413
3414       gnu_subprog_language->parm_attr_cache = NULL;
3415     }
3416
3417   /* If we are dealing with a return from an Ada procedure with parameters
3418      passed by copy-in/copy-out, we need to return a record containing the
3419      final values of these parameters.  If the list contains only one entry,
3420      return just that entry though.
3421
3422      For a full description of the copy-in/copy-out parameter mechanism, see
3423      the part of the gnat_to_gnu_entity routine dealing with the translation
3424      of subprograms.
3425
3426      We need to make a block that contains the definition of that label and
3427      the copying of the return value.  It first contains the function, then
3428      the label and copy statement.  */
3429   if (gnu_cico_list)
3430     {
3431       tree gnu_retval;
3432
3433       add_stmt (gnu_result);
3434       add_stmt (build1 (LABEL_EXPR, void_type_node,
3435                         VEC_last (tree, gnu_return_label_stack)));
3436
3437       if (list_length (gnu_cico_list) == 1)
3438         gnu_retval = TREE_VALUE (gnu_cico_list);
3439       else
3440         gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
3441                                                   gnu_cico_list);
3442
3443       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
3444                           End_Label (Handled_Statement_Sequence (gnat_node)));
3445       gnat_poplevel ();
3446       gnu_result = end_stmt_group ();
3447     }
3448
3449   VEC_pop (tree, gnu_return_label_stack);
3450
3451   /* Attempt setting the end_locus of our GCC body tree, typically a
3452      BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
3453      declaration tree.  */
3454   set_end_locus_from_node (gnu_result, gnat_node);
3455   set_end_locus_from_node (gnu_subprog_decl, gnat_node);
3456
3457   end_subprog_body (gnu_result);
3458
3459   /* Finally annotate the parameters and disconnect the trees for parameters
3460      that we have turned into variables since they are now unusable.  */
3461   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3462        Present (gnat_param);
3463        gnat_param = Next_Formal_With_Extras (gnat_param))
3464     {
3465       tree gnu_param = get_gnu_tree (gnat_param);
3466       bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
3467
3468       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
3469                        DECL_BY_REF_P (gnu_param),
3470                        !is_var_decl && DECL_BY_DOUBLE_REF_P (gnu_param));
3471
3472       if (is_var_decl)
3473         save_gnu_tree (gnat_param, NULL_TREE, false);
3474     }
3475
3476   /* Disconnect the variable created for the return value.  */
3477   if (gnu_return_var_elmt)
3478     TREE_VALUE (gnu_return_var_elmt) = void_type_node;
3479
3480   /* If the function returns an aggregate type and we have candidates for
3481      a Named Return Value, finalize the optimization.  */
3482   if (optimize && gnu_subprog_language->named_ret_val)
3483     {
3484       finalize_nrv (gnu_subprog_decl,
3485                     gnu_subprog_language->named_ret_val,
3486                     gnu_subprog_language->other_ret_val,
3487                     gnu_subprog_language->gnat_ret);
3488       gnu_subprog_language->named_ret_val = NULL;
3489       gnu_subprog_language->other_ret_val = NULL;
3490     }
3491
3492   rest_of_subprog_body_compilation (gnu_subprog_decl);
3493
3494   /* If there is a stub associated with the function, build it now.  */
3495   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
3496     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
3497
3498   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
3499 }
3500 \f
3501 /* Return true if GNAT_NODE requires atomic synchronization.  */
3502
3503 static bool
3504 atomic_sync_required_p (Node_Id gnat_node)
3505 {
3506   const Node_Id gnat_parent = Parent (gnat_node);
3507   Node_Kind kind;
3508   unsigned char attr_id;
3509
3510   /* First, scan the node to find the Atomic_Sync_Required flag.  */
3511   kind = Nkind (gnat_node);
3512   if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
3513     {
3514       gnat_node = Expression (gnat_node);
3515       kind = Nkind (gnat_node);
3516     }
3517
3518   switch (kind)
3519     {
3520     case N_Expanded_Name:
3521     case N_Explicit_Dereference:
3522     case N_Identifier:
3523     case N_Indexed_Component:
3524     case N_Selected_Component:
3525       if (!Atomic_Sync_Required (gnat_node))
3526         return false;
3527       break;
3528
3529     default:
3530       return false;
3531     }
3532
3533   /* Then, scan the parent to find out cases where the flag is irrelevant.  */
3534   kind = Nkind (gnat_parent);
3535   switch (kind)
3536     {
3537     case N_Attribute_Reference:
3538       attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
3539       /* Do not mess up machine code insertions.  */
3540       if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
3541         return false;
3542       break;
3543
3544     case N_Object_Renaming_Declaration:
3545       /* Do not generate a function call as a renamed object.  */
3546       return false;
3547
3548     default:
3549       break;
3550     }
3551
3552   return true;
3553 }
3554 \f
3555 /* Create a temporary variable with PREFIX and TYPE, and return it.  */
3556
3557 static tree
3558 create_temporary (const char *prefix, tree type)
3559 {
3560   tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
3561                                    type, NULL_TREE, false, false, false, false,
3562                                    NULL, Empty);
3563   DECL_ARTIFICIAL (gnu_temp) = 1;
3564   DECL_IGNORED_P (gnu_temp) = 1;
3565
3566   return gnu_temp;
3567 }
3568
3569 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
3570    Put the initialization statement into GNU_INIT_STMT and annotate it with
3571    the SLOC of GNAT_NODE.  Return the temporary variable.  */
3572
3573 static tree
3574 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
3575                        Node_Id gnat_node)
3576 {
3577   tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
3578
3579   *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
3580   set_expr_location_from_node (*gnu_init_stmt, gnat_node);
3581
3582   return gnu_temp;
3583 }
3584
3585 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
3586    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
3587    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
3588    If GNU_TARGET is non-null, this must be a function call on the RHS of a
3589    N_Assignment_Statement and the result is to be placed into that object.
3590    If, in addition, ATOMIC_SYNC is true, then the assignment to GNU_TARGET
3591    requires atomic synchronization.  */
3592
3593 static tree
3594 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
3595              bool atomic_sync)
3596 {
3597   const bool function_call = (Nkind (gnat_node) == N_Function_Call);
3598   const bool returning_value = (function_call && !gnu_target);
3599   /* The GCC node corresponding to the GNAT subprogram name.  This can either
3600      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
3601      or an indirect reference expression (an INDIRECT_REF node) pointing to a
3602      subprogram.  */
3603   tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
3604   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
3605   tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
3606   /* The return type of the FUNCTION_TYPE.  */
3607   tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
3608   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
3609   VEC(tree,gc) *gnu_actual_vec = NULL;
3610   tree gnu_name_list = NULL_TREE;
3611   tree gnu_stmt_list = NULL_TREE;
3612   tree gnu_after_list = NULL_TREE;
3613   tree gnu_retval = NULL_TREE;
3614   tree gnu_call, gnu_result;
3615   bool went_into_elab_proc = false;
3616   bool pushed_binding_level = false;
3617   Entity_Id gnat_formal;
3618   Node_Id gnat_actual;
3619
3620   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
3621
3622   /* If we are calling a stubbed function, raise Program_Error, but Elaborate
3623      all our args first.  */
3624   if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
3625     {
3626       tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
3627                                          gnat_node, N_Raise_Program_Error);
3628
3629       for (gnat_actual = First_Actual (gnat_node);
3630            Present (gnat_actual);
3631            gnat_actual = Next_Actual (gnat_actual))
3632         add_stmt (gnat_to_gnu (gnat_actual));
3633
3634       if (returning_value)
3635         {
3636           *gnu_result_type_p = gnu_result_type;
3637           return build1 (NULL_EXPR, gnu_result_type, call_expr);
3638         }
3639
3640       return call_expr;
3641     }
3642
3643   /* The only way we can be making a call via an access type is if Name is an
3644      explicit dereference.  In that case, get the list of formal args from the
3645      type the access type is pointing to.  Otherwise, get the formals from the
3646      entity being called.  */
3647   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3648     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
3649   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
3650     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
3651     gnat_formal = Empty;
3652   else
3653     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
3654
3655   /* The lifetime of the temporaries created for the call ends right after the
3656      return value is copied, so we can give them the scope of the elaboration
3657      routine at top level.  */
3658   if (!current_function_decl)
3659     {
3660       current_function_decl = get_elaboration_procedure ();
3661       went_into_elab_proc = true;
3662     }
3663
3664   /* First, create the temporary for the return value when:
3665
3666        1. There is no target and the function has copy-in/copy-out parameters,
3667           because we need to preserve the return value before copying back the
3668           parameters.
3669
3670        2. There is no target and this is not an object declaration, and the
3671           return type has variable size, because in these cases the gimplifier
3672           cannot create the temporary.
3673
3674        3. There is a target and it is a slice or an array with fixed size,
3675           and the return type has variable size, because the gimplifier
3676           doesn't handle these cases.
3677
3678      This must be done before we push a binding level around the call, since
3679      we will pop it before copying the return value.  */
3680   if (function_call
3681       && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
3682           || (!gnu_target
3683               && Nkind (Parent (gnat_node)) != N_Object_Declaration
3684               && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
3685           || (gnu_target
3686               && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
3687                   || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
3688                       && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
3689                          == INTEGER_CST))
3690               && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
3691     gnu_retval = create_temporary ("R", gnu_result_type);
3692
3693   /* Create the list of the actual parameters as GCC expects it, namely a
3694      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
3695      is an expression and the TREE_PURPOSE field is null.  But skip Out
3696      parameters not passed by reference and that need not be copied in.  */
3697   for (gnat_actual = First_Actual (gnat_node);
3698        Present (gnat_actual);
3699        gnat_formal = Next_Formal_With_Extras (gnat_formal),
3700        gnat_actual = Next_Actual (gnat_actual))
3701     {
3702       tree gnu_formal = present_gnu_tree (gnat_formal)
3703                         ? get_gnu_tree (gnat_formal) : NULL_TREE;
3704       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
3705       const bool is_true_formal_parm
3706         = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
3707       const bool is_by_ref_formal_parm
3708         = is_true_formal_parm
3709           && (DECL_BY_REF_P (gnu_formal)
3710               || DECL_BY_COMPONENT_PTR_P (gnu_formal)
3711               || DECL_BY_DESCRIPTOR_P (gnu_formal));
3712       /* In the Out or In Out case, we must suppress conversions that yield
3713          an lvalue but can nevertheless cause the creation of a temporary,
3714          because we need the real object in this case, either to pass its
3715          address if it's passed by reference or as target of the back copy
3716          done after the call if it uses the copy-in/copy-out mechanism.
3717          We do it in the In case too, except for an unchecked conversion
3718          because it alone can cause the actual to be misaligned and the
3719          addressability test is applied to the real object.  */
3720       const bool suppress_type_conversion
3721         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
3722             && Ekind (gnat_formal) != E_In_Parameter)
3723            || (Nkind (gnat_actual) == N_Type_Conversion
3724                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
3725       Node_Id gnat_name = suppress_type_conversion
3726                           ? Expression (gnat_actual) : gnat_actual;
3727       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
3728       tree gnu_actual;
3729
3730       /* If it's possible we may need to use this expression twice, make sure
3731          that any side-effects are handled via SAVE_EXPRs; likewise if we need
3732          to force side-effects before the call.
3733          ??? This is more conservative than we need since we don't need to do
3734          this for pass-by-ref with no conversion.  */
3735       if (Ekind (gnat_formal) != E_In_Parameter)
3736         gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
3737
3738       /* If we are passing a non-addressable parameter by reference, pass the
3739          address of a copy.  In the Out or In Out case, set up to copy back
3740          out after the call.  */
3741       if (is_by_ref_formal_parm
3742           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
3743           && !addressable_p (gnu_name, gnu_name_type))
3744         {
3745           bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
3746           tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
3747
3748           /* Do not issue warnings for CONSTRUCTORs since this is not a copy
3749              but sort of an instantiation for them.  */
3750           if (TREE_CODE (gnu_name) == CONSTRUCTOR)
3751             ;
3752
3753           /* If the type is passed by reference, a copy is not allowed.  */
3754           else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type))
3755             post_error ("misaligned actual cannot be passed by reference",
3756                         gnat_actual);
3757
3758           /* For users of Starlet we issue a warning because the interface
3759              apparently assumes that by-ref parameters outlive the procedure
3760              invocation.  The code still will not work as intended, but we
3761              cannot do much better since low-level parts of the back-end
3762              would allocate temporaries at will because of the misalignment
3763              if we did not do so here.  */
3764           else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
3765             {
3766               post_error
3767                 ("?possible violation of implicit assumption", gnat_actual);
3768               post_error_ne
3769                 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
3770                  Entity (Name (gnat_node)));
3771               post_error_ne ("?because of misalignment of &", gnat_actual,
3772                              gnat_formal);
3773             }
3774
3775           /* If the actual type of the object is already the nominal type,
3776              we have nothing to do, except if the size is self-referential
3777              in which case we'll remove the unpadding below.  */
3778           if (TREE_TYPE (gnu_name) == gnu_name_type
3779               && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
3780             ;
3781
3782           /* Otherwise remove the unpadding from all the objects.  */
3783           else if (TREE_CODE (gnu_name) == COMPONENT_REF
3784                    && TYPE_IS_PADDING_P
3785                       (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
3786             gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
3787
3788           /* Otherwise convert to the nominal type of the object if needed.
3789              There are several cases in which we need to make the temporary
3790              using this type instead of the actual type of the object when
3791              they are distinct, because the expectations of the callee would
3792              otherwise not be met:
3793                - if it's a justified modular type,
3794                - if the actual type is a smaller form of it,
3795                - if it's a smaller form of the actual type.  */
3796           else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
3797                     && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
3798                         || smaller_form_type_p (TREE_TYPE (gnu_name),
3799                                                 gnu_name_type)))
3800                    || (INTEGRAL_TYPE_P (gnu_name_type)
3801                        && smaller_form_type_p (gnu_name_type,
3802                                                TREE_TYPE (gnu_name))))
3803             gnu_name = convert (gnu_name_type, gnu_name);
3804
3805           /* If this is an In Out or Out parameter and we're returning a value,
3806              we need to create a temporary for the return value because we must
3807              preserve it before copying back at the very end.  */
3808           if (!in_param && returning_value && !gnu_retval)
3809             gnu_retval = create_temporary ("R", gnu_result_type);
3810
3811           /* If we haven't pushed a binding level, push a new one.  This will
3812              narrow the lifetime of the temporary we are about to make as much
3813              as possible.  The drawback is that we'd need to create a temporary
3814              for the return value, if any (see comment before the loop).  So do
3815              it only when this temporary was already created just above.  */
3816           if (!pushed_binding_level && !(in_param && returning_value))
3817             {
3818               start_stmt_group ();
3819               gnat_pushlevel ();
3820               pushed_binding_level = true;
3821             }
3822
3823           /* Create an explicit temporary holding the copy.  */
3824           gnu_temp
3825             = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
3826
3827           /* But initialize it on the fly like for an implicit temporary as
3828              we aren't necessarily having a statement list.  */
3829           gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
3830                                           gnu_temp);
3831
3832           /* Set up to move the copy back to the original if needed.  */
3833           if (!in_param)
3834             {
3835               gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
3836                                           gnu_temp);
3837               set_expr_location_from_node (gnu_stmt, gnat_node);
3838               append_to_statement_list (gnu_stmt, &gnu_after_list);
3839             }
3840         }
3841
3842       /* Start from the real object and build the actual.  */
3843       gnu_actual = gnu_name;
3844
3845       /* If this is an atomic access of an In or In Out parameter for which
3846          synchronization is required, build the atomic load.  */
3847       if (is_true_formal_parm
3848           && !is_by_ref_formal_parm
3849           && Ekind (gnat_formal) != E_Out_Parameter
3850           && atomic_sync_required_p (gnat_actual))
3851         gnu_actual = build_atomic_load (gnu_actual);
3852
3853       /* If this was a procedure call, we may not have removed any padding.
3854          So do it here for the part we will use as an input, if any.  */
3855       if (Ekind (gnat_formal) != E_Out_Parameter
3856           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
3857         gnu_actual
3858           = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
3859
3860       /* Put back the conversion we suppressed above in the computation of the
3861          real object.  And even if we didn't suppress any conversion there, we
3862          may have suppressed a conversion to the Etype of the actual earlier,
3863          since the parent is a procedure call, so put it back here.  */
3864       if (suppress_type_conversion
3865           && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
3866         gnu_actual
3867           = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
3868                                gnu_actual, No_Truncation (gnat_actual));
3869       else
3870         gnu_actual
3871           = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
3872
3873       /* Make sure that the actual is in range of the formal's type.  */
3874       if (Ekind (gnat_formal) != E_Out_Parameter
3875           && Do_Range_Check (gnat_actual))
3876         gnu_actual
3877           = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
3878
3879       /* Unless this is an In parameter, we must remove any justified modular
3880          building from GNU_NAME to get an lvalue.  */
3881       if (Ekind (gnat_formal) != E_In_Parameter
3882           && TREE_CODE (gnu_name) == CONSTRUCTOR
3883           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
3884           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
3885         gnu_name
3886           = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
3887
3888       /* If we have not saved a GCC object for the formal, it means it is an
3889          Out parameter not passed by reference and that need not be copied in.
3890          Otherwise, first see if the parameter is passed by reference.  */
3891       if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
3892         {
3893           if (Ekind (gnat_formal) != E_In_Parameter)
3894             {
3895               /* In Out or Out parameters passed by reference don't use the
3896                  copy-in/copy-out mechanism so the address of the real object
3897                  must be passed to the function.  */
3898               gnu_actual = gnu_name;
3899
3900               /* If we have a padded type, be sure we've removed padding.  */
3901               if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
3902                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
3903                                       gnu_actual);
3904
3905               /* If we have the constructed subtype of an aliased object
3906                  with an unconstrained nominal subtype, the type of the
3907                  actual includes the template, although it is formally
3908                  constrained.  So we need to convert it back to the real
3909                  constructed subtype to retrieve the constrained part
3910                  and takes its address.  */
3911               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
3912                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
3913                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
3914                   && Is_Array_Type (Etype (gnat_actual)))
3915                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
3916                                       gnu_actual);
3917             }
3918
3919           /* There is no need to convert the actual to the formal's type before
3920              taking its address.  The only exception is for unconstrained array
3921              types because of the way we build fat pointers.  */
3922           if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
3923             {
3924               /* Put back a view conversion for In Out or Out parameters.  */
3925               if (Ekind (gnat_formal) != E_In_Parameter)
3926                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
3927                                       gnu_actual);
3928               gnu_actual = convert (gnu_formal_type, gnu_actual);
3929             }
3930
3931           /* The symmetry of the paths to the type of an entity is broken here
3932              since arguments don't know that they will be passed by ref.  */
3933           gnu_formal_type = TREE_TYPE (gnu_formal);
3934
3935           if (DECL_BY_DOUBLE_REF_P (gnu_formal))
3936             gnu_actual
3937               = build_unary_op (ADDR_EXPR, TREE_TYPE (gnu_formal_type),
3938                                 gnu_actual);
3939
3940           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
3941         }
3942       else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
3943         {
3944           gnu_formal_type = TREE_TYPE (gnu_formal);
3945           gnu_actual = maybe_implicit_deref (gnu_actual);
3946           gnu_actual = maybe_unconstrained_array (gnu_actual);
3947
3948           if (TYPE_IS_PADDING_P (gnu_formal_type))
3949             {
3950               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
3951               gnu_actual = convert (gnu_formal_type, gnu_actual);
3952             }
3953
3954           /* Take the address of the object and convert to the proper pointer
3955              type.  We'd like to actually compute the address of the beginning
3956              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
3957              possibility that the ARRAY_REF might return a constant and we'd be
3958              getting the wrong address.  Neither approach is exactly correct,
3959              but this is the most likely to work in all cases.  */
3960           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
3961         }
3962       else if (is_true_formal_parm && DECL_BY_DESCRIPTOR_P (gnu_formal))
3963         {
3964           gnu_actual = convert (gnu_formal_type, gnu_actual);
3965
3966           /* If this is 'Null_Parameter, pass a zero descriptor.  */
3967           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
3968                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
3969               && TREE_PRIVATE (gnu_actual))
3970             gnu_actual
3971               = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
3972           else
3973             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
3974                                          fill_vms_descriptor
3975                                          (TREE_TYPE (TREE_TYPE (gnu_formal)),
3976                                           gnu_actual, gnat_actual));
3977         }
3978       else
3979         {
3980           tree gnu_size;
3981
3982           if (Ekind (gnat_formal) != E_In_Parameter)
3983             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
3984
3985           if (!is_true_formal_parm)
3986             {
3987               /* Make sure side-effects are evaluated before the call.  */
3988               if (TREE_SIDE_EFFECTS (gnu_name))
3989                 append_to_statement_list (gnu_name, &gnu_stmt_list);
3990               continue;
3991             }
3992
3993           gnu_actual = convert (gnu_formal_type, gnu_actual);
3994
3995           /* If this is 'Null_Parameter, pass a zero even though we are
3996              dereferencing it.  */
3997           if (TREE_CODE (gnu_actual) == INDIRECT_REF
3998               && TREE_PRIVATE (gnu_actual)
3999               && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
4000               && TREE_CODE (gnu_size) == INTEGER_CST
4001               && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
4002             gnu_actual
4003               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
4004                                    convert (gnat_type_for_size
4005                                             (TREE_INT_CST_LOW (gnu_size), 1),
4006                                             integer_zero_node),
4007                                    false);
4008           else
4009             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
4010         }
4011
4012       VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual);
4013     }
4014
4015   gnu_call
4016     = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
4017   set_expr_location_from_node (gnu_call, gnat_node);
4018
4019   /* If we have created a temporary for the return value, initialize it.  */
4020   if (gnu_retval)
4021     {
4022       tree gnu_stmt
4023         = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
4024       set_expr_location_from_node (gnu_stmt, gnat_node);
4025       append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4026       gnu_call = gnu_retval;
4027     }
4028
4029   /* If this is a subprogram with copy-in/copy-out parameters, we need to
4030      unpack the valued returned from the function into the In Out or Out
4031      parameters.  We deal with the function return (if this is an Ada
4032      function) below.  */
4033   if (TYPE_CI_CO_LIST (gnu_subprog_type))
4034     {
4035       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
4036          copy-out parameters.  */
4037       tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
4038       const int length = list_length (gnu_cico_list);
4039
4040       /* The call sequence must contain one and only one call, even though the
4041          function is pure.  Save the result into a temporary if needed.  */
4042       if (length > 1)
4043         {
4044           if (!gnu_retval)
4045             {
4046               tree gnu_stmt;
4047               /* If we haven't pushed a binding level, push a new one.  This
4048                  will narrow the lifetime of the temporary we are about to
4049                  make as much as possible.  */
4050               if (!pushed_binding_level)
4051                 {
4052                   start_stmt_group ();
4053                   gnat_pushlevel ();
4054                   pushed_binding_level = true;
4055                 }
4056               gnu_call
4057                 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
4058               append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4059             }
4060
4061           gnu_name_list = nreverse (gnu_name_list);
4062         }
4063
4064       /* The first entry is for the actual return value if this is a
4065          function, so skip it.  */
4066       if (function_call)
4067         gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4068
4069       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4070         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4071       else
4072         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4073
4074       for (gnat_actual = First_Actual (gnat_node);
4075            Present (gnat_actual);
4076            gnat_formal = Next_Formal_With_Extras (gnat_formal),
4077            gnat_actual = Next_Actual (gnat_actual))
4078         /* If we are dealing with a copy-in/copy-out parameter, we must
4079            retrieve its value from the record returned in the call.  */
4080         if (!(present_gnu_tree (gnat_formal)
4081               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
4082               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
4083                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
4084                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
4085                            || (DECL_BY_DESCRIPTOR_P
4086                                (get_gnu_tree (gnat_formal))))))))
4087             && Ekind (gnat_formal) != E_In_Parameter)
4088           {
4089             /* Get the value to assign to this Out or In Out parameter.  It is
4090                either the result of the function if there is only a single such
4091                parameter or the appropriate field from the record returned.  */
4092             tree gnu_result
4093               = length == 1
4094                 ? gnu_call
4095                 : build_component_ref (gnu_call, NULL_TREE,
4096                                        TREE_PURPOSE (gnu_cico_list), false);
4097
4098             /* If the actual is a conversion, get the inner expression, which
4099                will be the real destination, and convert the result to the
4100                type of the actual parameter.  */
4101             tree gnu_actual
4102               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
4103
4104             /* If the result is a padded type, remove the padding.  */
4105             if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4106               gnu_result
4107                 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4108                            gnu_result);
4109
4110             /* If the actual is a type conversion, the real target object is
4111                denoted by the inner Expression and we need to convert the
4112                result to the associated type.
4113                We also need to convert our gnu assignment target to this type
4114                if the corresponding GNU_NAME was constructed from the GNAT
4115                conversion node and not from the inner Expression.  */
4116             if (Nkind (gnat_actual) == N_Type_Conversion)
4117               {
4118                 gnu_result
4119                   = convert_with_check
4120                     (Etype (Expression (gnat_actual)), gnu_result,
4121                      Do_Overflow_Check (gnat_actual),
4122                      Do_Range_Check (Expression (gnat_actual)),
4123                      Float_Truncate (gnat_actual), gnat_actual);
4124
4125                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
4126                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
4127               }
4128
4129             /* Unchecked conversions as actuals for Out parameters are not
4130                allowed in user code because they are not variables, but do
4131                occur in front-end expansions.  The associated GNU_NAME is
4132                always obtained from the inner expression in such cases.  */
4133             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4134               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
4135                                               gnu_result,
4136                                               No_Truncation (gnat_actual));
4137             else
4138               {
4139                 if (Do_Range_Check (gnat_actual))
4140                   gnu_result
4141                     = emit_range_check (gnu_result, Etype (gnat_actual),
4142                                         gnat_actual);
4143
4144                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
4145                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
4146                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
4147               }
4148
4149             if (atomic_sync_required_p (gnat_actual))
4150               gnu_result = build_atomic_store (gnu_actual, gnu_result);
4151             else
4152               gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
4153                                             gnu_actual, gnu_result);
4154             set_expr_location_from_node (gnu_result, gnat_node);
4155             append_to_statement_list (gnu_result, &gnu_stmt_list);
4156             gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4157             gnu_name_list = TREE_CHAIN (gnu_name_list);
4158           }
4159     }
4160
4161   /* If this is a function call, the result is the call expression unless a
4162      target is specified, in which case we copy the result into the target
4163      and return the assignment statement.  */
4164   if (function_call)
4165     {
4166       /* If this is a function with copy-in/copy-out parameters, extract the
4167          return value from it and update the return type.  */
4168       if (TYPE_CI_CO_LIST (gnu_subprog_type))
4169         {
4170           tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
4171           gnu_call = build_component_ref (gnu_call, NULL_TREE,
4172                                           TREE_PURPOSE (gnu_elmt), false);
4173           gnu_result_type = TREE_TYPE (gnu_call);
4174         }
4175
4176       /* If the function returns an unconstrained array or by direct reference,
4177          we have to dereference the pointer.  */
4178       if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
4179           || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
4180         gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
4181
4182       if (gnu_target)
4183         {
4184           Node_Id gnat_parent = Parent (gnat_node);
4185           enum tree_code op_code;
4186
4187           /* If range check is needed, emit code to generate it.  */
4188           if (Do_Range_Check (gnat_node))
4189             gnu_call
4190               = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
4191                                   gnat_parent);
4192
4193           /* ??? If the return type has variable size, then force the return
4194              slot optimization as we would not be able to create a temporary.
4195              Likewise if it was unconstrained as we would copy too much data.
4196              That's what has been done historically.  */
4197           if (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4198               || (TYPE_IS_PADDING_P (gnu_result_type)
4199                   && CONTAINS_PLACEHOLDER_P
4200                      (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type))))))
4201             op_code = INIT_EXPR;
4202           else
4203             op_code = MODIFY_EXPR;
4204
4205           if (atomic_sync)
4206             gnu_call = build_atomic_store (gnu_target, gnu_call);
4207           else
4208             gnu_call
4209               = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
4210           set_expr_location_from_node (gnu_call, gnat_parent);
4211           append_to_statement_list (gnu_call, &gnu_stmt_list);
4212         }
4213       else
4214         *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
4215     }
4216
4217   /* Otherwise, if this is a procedure call statement without copy-in/copy-out
4218      parameters, the result is just the call statement.  */
4219   else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
4220     append_to_statement_list (gnu_call, &gnu_stmt_list);
4221
4222   /* Finally, add the copy back statements, if any.  */
4223   append_to_statement_list (gnu_after_list, &gnu_stmt_list);
4224
4225   if (went_into_elab_proc)
4226     current_function_decl = NULL_TREE;
4227
4228   /* If we have pushed a binding level, pop it and finish up the enclosing
4229      statement group.  */
4230   if (pushed_binding_level)
4231     {
4232       add_stmt (gnu_stmt_list);
4233       gnat_poplevel ();
4234       gnu_result = end_stmt_group ();
4235     }
4236
4237   /* Otherwise, retrieve the statement list, if any.  */
4238   else if (gnu_stmt_list)
4239     gnu_result = gnu_stmt_list;
4240
4241   /* Otherwise, just return the call expression.  */
4242   else
4243     return gnu_call;
4244
4245   /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
4246      But first simplify if we have only one statement in the list.  */
4247   if (returning_value)
4248     {
4249       tree first = expr_first (gnu_result), last = expr_last (gnu_result);
4250       if (first == last)
4251         gnu_result = first;
4252       gnu_result
4253         = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
4254     }
4255
4256   return gnu_result;
4257 }
4258 \f
4259 /* Subroutine of gnat_to_gnu to translate gnat_node, an
4260    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
4261
4262 static tree
4263 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
4264 {
4265   tree gnu_jmpsave_decl = NULL_TREE;
4266   tree gnu_jmpbuf_decl = NULL_TREE;
4267   /* If just annotating, ignore all EH and cleanups.  */
4268   bool gcc_zcx = (!type_annotate_only
4269                   && Present (Exception_Handlers (gnat_node))
4270                   && Exception_Mechanism == Back_End_Exceptions);
4271   bool setjmp_longjmp
4272     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
4273        && Exception_Mechanism == Setjmp_Longjmp);
4274   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
4275   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
4276   tree gnu_inner_block; /* The statement(s) for the block itself.  */
4277   tree gnu_result;
4278   tree gnu_expr;
4279   Node_Id gnat_temp;
4280
4281   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
4282      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
4283      add_cleanup, and when we leave the binding, end_stmt_group will create
4284      the TRY_FINALLY_EXPR.
4285
4286      ??? The region level calls down there have been specifically put in place
4287      for a ZCX context and currently the order in which things are emitted
4288      (region/handlers) is different from the SJLJ case. Instead of putting
4289      other calls with different conditions at other places for the SJLJ case,
4290      it seems cleaner to reorder things for the SJLJ case and generalize the
4291      condition to make it not ZCX specific.
4292
4293      If there are any exceptions or cleanup processing involved, we need an
4294      outer statement group (for Setjmp_Longjmp) and binding level.  */
4295   if (binding_for_block)
4296     {
4297       start_stmt_group ();
4298       gnat_pushlevel ();
4299     }
4300
4301   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
4302      area for address of previous buffer.  Do this first since we need to have
4303      the setjmp buf known for any decls in this block.  */
4304   if (setjmp_longjmp)
4305     {
4306       gnu_jmpsave_decl
4307         = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
4308                            jmpbuf_ptr_type,
4309                            build_call_n_expr (get_jmpbuf_decl, 0),
4310                            false, false, false, false, NULL, gnat_node);
4311       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
4312
4313       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
4314          because of the unstructured form of EH used by setjmp_longjmp, there
4315          might be forward edges going to __builtin_setjmp receivers on which
4316          it is uninitialized, although they will never be actually taken.  */
4317       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
4318       gnu_jmpbuf_decl
4319         = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
4320                            jmpbuf_type,
4321                            NULL_TREE,
4322                            false, false, false, false, NULL, gnat_node);
4323       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
4324
4325       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
4326
4327       /* When we exit this block, restore the saved value.  */
4328       add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
4329                    End_Label (gnat_node));
4330     }
4331
4332   /* If we are to call a function when exiting this block, add a cleanup
4333      to the binding level we made above.  Note that add_cleanup is FIFO
4334      so we must register this cleanup after the EH cleanup just above.  */
4335   if (at_end)
4336     add_cleanup (build_call_n_expr (gnat_to_gnu (At_End_Proc (gnat_node)), 0),
4337                  End_Label (gnat_node));
4338
4339   /* Now build the tree for the declarations and statements inside this block.
4340      If this is SJLJ, set our jmp_buf as the current buffer.  */
4341   start_stmt_group ();
4342
4343   if (setjmp_longjmp)
4344     add_stmt (build_call_n_expr (set_jmpbuf_decl, 1,
4345                                  build_unary_op (ADDR_EXPR, NULL_TREE,
4346                                                  gnu_jmpbuf_decl)));
4347
4348   if (Present (First_Real_Statement (gnat_node)))
4349     process_decls (Statements (gnat_node), Empty,
4350                    First_Real_Statement (gnat_node), true, true);
4351
4352   /* Generate code for each statement in the block.  */
4353   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
4354                     ? First_Real_Statement (gnat_node)
4355                     : First (Statements (gnat_node)));
4356        Present (gnat_temp); gnat_temp = Next (gnat_temp))
4357     add_stmt (gnat_to_gnu (gnat_temp));
4358   gnu_inner_block = end_stmt_group ();
4359
4360   /* Now generate code for the two exception models, if either is relevant for
4361      this block.  */
4362   if (setjmp_longjmp)
4363     {
4364       tree *gnu_else_ptr = 0;
4365       tree gnu_handler;
4366
4367       /* Make a binding level for the exception handling declarations and code
4368          and set up gnu_except_ptr_stack for the handlers to use.  */
4369       start_stmt_group ();
4370       gnat_pushlevel ();
4371
4372       VEC_safe_push (tree, gc, gnu_except_ptr_stack,
4373                      create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
4374                                       build_pointer_type (except_type_node),
4375                                       build_call_n_expr (get_excptr_decl, 0),
4376                                       false, false, false, false,
4377                                       NULL, gnat_node));
4378
4379       /* Generate code for each handler. The N_Exception_Handler case does the
4380          real work and returns a COND_EXPR for each handler, which we chain
4381          together here.  */
4382       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
4383            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
4384         {
4385           gnu_expr = gnat_to_gnu (gnat_temp);
4386
4387           /* If this is the first one, set it as the outer one. Otherwise,
4388              point the "else" part of the previous handler to us. Then point
4389              to our "else" part.  */
4390           if (!gnu_else_ptr)
4391             add_stmt (gnu_expr);
4392           else
4393             *gnu_else_ptr = gnu_expr;
4394
4395           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
4396         }
4397
4398       /* If none of the exception handlers did anything, re-raise but do not
4399          defer abortion.  */
4400       gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
4401                                     VEC_last (tree, gnu_except_ptr_stack));
4402       set_expr_location_from_node
4403         (gnu_expr,
4404          Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
4405
4406       if (gnu_else_ptr)
4407         *gnu_else_ptr = gnu_expr;
4408       else
4409         add_stmt (gnu_expr);
4410
4411       /* End the binding level dedicated to the exception handlers and get the
4412          whole statement group.  */
4413       VEC_pop (tree, gnu_except_ptr_stack);
4414       gnat_poplevel ();
4415       gnu_handler = end_stmt_group ();
4416
4417       /* If the setjmp returns 1, we restore our incoming longjmp value and
4418          then check the handlers.  */
4419       start_stmt_group ();
4420       add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1,
4421                                              gnu_jmpsave_decl),
4422                           gnat_node);
4423       add_stmt (gnu_handler);
4424       gnu_handler = end_stmt_group ();
4425
4426       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
4427       gnu_result = build3 (COND_EXPR, void_type_node,
4428                            (build_call_n_expr
4429                             (setjmp_decl, 1,
4430                              build_unary_op (ADDR_EXPR, NULL_TREE,
4431                                              gnu_jmpbuf_decl))),
4432                            gnu_handler, gnu_inner_block);
4433     }
4434   else if (gcc_zcx)
4435     {
4436       tree gnu_handlers;
4437
4438       /* First make a block containing the handlers.  */
4439       start_stmt_group ();
4440       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
4441            Present (gnat_temp);
4442            gnat_temp = Next_Non_Pragma (gnat_temp))
4443         add_stmt (gnat_to_gnu (gnat_temp));
4444       gnu_handlers = end_stmt_group ();
4445
4446       /* Now make the TRY_CATCH_EXPR for the block.  */
4447       gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
4448                            gnu_inner_block, gnu_handlers);
4449     }
4450   else
4451     gnu_result = gnu_inner_block;
4452
4453   /* Now close our outer block, if we had to make one.  */
4454   if (binding_for_block)
4455     {
4456       add_stmt (gnu_result);
4457       gnat_poplevel ();
4458       gnu_result = end_stmt_group ();
4459     }
4460
4461   return gnu_result;
4462 }
4463 \f
4464 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4465    to a GCC tree, which is returned.  This is the variant for Setjmp_Longjmp
4466    exception handling.  */
4467
4468 static tree
4469 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
4470 {
4471   /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
4472      an "if" statement to select the proper exceptions.  For "Others", exclude
4473      exceptions where Handled_By_Others is nonzero unless the All_Others flag
4474      is set. For "Non-ada", accept an exception if "Lang" is 'V'.  */
4475   tree gnu_choice = boolean_false_node;
4476   tree gnu_body = build_stmt_group (Statements (gnat_node), false);
4477   Node_Id gnat_temp;
4478
4479   for (gnat_temp = First (Exception_Choices (gnat_node));
4480        gnat_temp; gnat_temp = Next (gnat_temp))
4481     {
4482       tree this_choice;
4483
4484       if (Nkind (gnat_temp) == N_Others_Choice)
4485         {
4486           if (All_Others (gnat_temp))
4487             this_choice = boolean_true_node;
4488           else
4489             this_choice
4490               = build_binary_op
4491                 (EQ_EXPR, boolean_type_node,
4492                  convert
4493                  (integer_type_node,
4494                   build_component_ref
4495                   (build_unary_op
4496                    (INDIRECT_REF, NULL_TREE,
4497                     VEC_last (tree, gnu_except_ptr_stack)),
4498                    get_identifier ("not_handled_by_others"), NULL_TREE,
4499                    false)),
4500                  integer_zero_node);
4501         }
4502
4503       else if (Nkind (gnat_temp) == N_Identifier
4504                || Nkind (gnat_temp) == N_Expanded_Name)
4505         {
4506           Entity_Id gnat_ex_id = Entity (gnat_temp);
4507           tree gnu_expr;
4508
4509           /* Exception may be a renaming. Recover original exception which is
4510              the one elaborated and registered.  */
4511           if (Present (Renamed_Object (gnat_ex_id)))
4512             gnat_ex_id = Renamed_Object (gnat_ex_id);
4513
4514           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
4515
4516           this_choice
4517             = build_binary_op
4518               (EQ_EXPR, boolean_type_node,
4519                VEC_last (tree, gnu_except_ptr_stack),
4520                convert (TREE_TYPE (VEC_last (tree, gnu_except_ptr_stack)),
4521                         build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
4522
4523           /* If this is the distinguished exception "Non_Ada_Error" (and we are
4524              in VMS mode), also allow a non-Ada exception (a VMS condition) t
4525              match.  */
4526           if (Is_Non_Ada_Error (Entity (gnat_temp)))
4527             {
4528               tree gnu_comp
4529                 = build_component_ref
4530                   (build_unary_op (INDIRECT_REF, NULL_TREE,
4531                                    VEC_last (tree, gnu_except_ptr_stack)),
4532                    get_identifier ("lang"), NULL_TREE, false);
4533
4534               this_choice
4535                 = build_binary_op
4536                   (TRUTH_ORIF_EXPR, boolean_type_node,
4537                    build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp,
4538                                     build_int_cst (TREE_TYPE (gnu_comp), 'V')),
4539                    this_choice);
4540             }
4541         }
4542       else
4543         gcc_unreachable ();
4544
4545       gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
4546                                     gnu_choice, this_choice);
4547     }
4548
4549   return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
4550 }
4551 \f
4552 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4553    to a GCC tree, which is returned.  This is the variant for ZCX.  */
4554
4555 static tree
4556 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
4557 {
4558   tree gnu_etypes_list = NULL_TREE;
4559   tree gnu_expr;
4560   tree gnu_etype;
4561   tree gnu_current_exc_ptr;
4562   tree prev_gnu_incoming_exc_ptr;
4563   Node_Id gnat_temp;
4564
4565   /* We build a TREE_LIST of nodes representing what exception types this
4566      handler can catch, with special cases for others and all others cases.
4567
4568      Each exception type is actually identified by a pointer to the exception
4569      id, or to a dummy object for "others" and "all others".  */
4570   for (gnat_temp = First (Exception_Choices (gnat_node));
4571        gnat_temp; gnat_temp = Next (gnat_temp))
4572     {
4573       if (Nkind (gnat_temp) == N_Others_Choice)
4574         {
4575           tree gnu_expr
4576             = All_Others (gnat_temp) ? all_others_decl : others_decl;
4577
4578           gnu_etype
4579             = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
4580         }
4581       else if (Nkind (gnat_temp) == N_Identifier
4582                || Nkind (gnat_temp) == N_Expanded_Name)
4583         {
4584           Entity_Id gnat_ex_id = Entity (gnat_temp);
4585
4586           /* Exception may be a renaming. Recover original exception which is
4587              the one elaborated and registered.  */
4588           if (Present (Renamed_Object (gnat_ex_id)))
4589             gnat_ex_id = Renamed_Object (gnat_ex_id);
4590
4591           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
4592           gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
4593
4594           /* The Non_Ada_Error case for VMS exceptions is handled
4595              by the personality routine.  */
4596         }
4597       else
4598         gcc_unreachable ();
4599
4600       /* The GCC interface expects NULL to be passed for catch all handlers, so
4601          it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
4602          is integer_zero_node.  It would not work, however, because GCC's
4603          notion of "catch all" is stronger than our notion of "others".  Until
4604          we correctly use the cleanup interface as well, doing that would
4605          prevent the "all others" handlers from being seen, because nothing
4606          can be caught beyond a catch all from GCC's point of view.  */
4607       gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
4608     }
4609
4610   start_stmt_group ();
4611   gnat_pushlevel ();
4612
4613   /* Expand a call to the begin_handler hook at the beginning of the handler,
4614      and arrange for a call to the end_handler hook to occur on every possible
4615      exit path.
4616
4617      The hooks expect a pointer to the low level occurrence. This is required
4618      for our stack management scheme because a raise inside the handler pushes
4619      a new occurrence on top of the stack, which means that this top does not
4620      necessarily match the occurrence this handler was dealing with.
4621
4622      __builtin_eh_pointer references the exception occurrence being
4623      propagated. Upon handler entry, this is the exception for which the
4624      handler is triggered. This might not be the case upon handler exit,
4625      however, as we might have a new occurrence propagated by the handler's
4626      body, and the end_handler hook called as a cleanup in this context.
4627
4628      We use a local variable to retrieve the incoming value at handler entry
4629      time, and reuse it to feed the end_handler hook's argument at exit.  */
4630
4631   gnu_current_exc_ptr
4632     = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
4633                        1, integer_zero_node);
4634   prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
4635   gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
4636                                           ptr_type_node, gnu_current_exc_ptr,
4637                                           false, false, false, false,
4638                                           NULL, gnat_node);
4639
4640   add_stmt_with_node (build_call_n_expr (begin_handler_decl, 1,
4641                                          gnu_incoming_exc_ptr),
4642                       gnat_node);
4643   /* ??? We don't seem to have an End_Label at hand to set the location.  */
4644   add_cleanup (build_call_n_expr (end_handler_decl, 1, gnu_incoming_exc_ptr),
4645                Empty);
4646   add_stmt_list (Statements (gnat_node));
4647   gnat_poplevel ();
4648
4649   gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
4650
4651   return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
4652                  end_stmt_group ());
4653 }
4654 \f
4655 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
4656
4657 static void
4658 Compilation_Unit_to_gnu (Node_Id gnat_node)
4659 {
4660   const Node_Id gnat_unit = Unit (gnat_node);
4661   const bool body_p = (Nkind (gnat_unit) == N_Package_Body
4662                        || Nkind (gnat_unit) == N_Subprogram_Body);
4663   const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
4664   /* Make the decl for the elaboration procedure.  */
4665   tree gnu_elab_proc_decl
4666     = create_subprog_decl
4667       (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
4668        NULL_TREE, void_ftype, NULL_TREE, false, true, false, true, NULL,
4669        gnat_unit);
4670   struct elab_info *info;
4671
4672   VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl);
4673   DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
4674
4675   /* Initialize the information structure for the function.  */
4676   allocate_struct_function (gnu_elab_proc_decl, false);
4677   set_cfun (NULL);
4678
4679   current_function_decl = NULL_TREE;
4680
4681   start_stmt_group ();
4682   gnat_pushlevel ();
4683
4684   /* For a body, first process the spec if there is one.  */
4685   if (Nkind (gnat_unit) == N_Package_Body
4686       || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
4687     add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
4688
4689   if (type_annotate_only && gnat_node == Cunit (Main_Unit))
4690     {
4691       elaborate_all_entities (gnat_node);
4692
4693       if (Nkind (gnat_unit) == N_Subprogram_Declaration
4694           || Nkind (gnat_unit) == N_Generic_Package_Declaration
4695           || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
4696         return;
4697     }
4698
4699   process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
4700                  true, true);
4701   add_stmt (gnat_to_gnu (gnat_unit));
4702
4703   /* If we can inline, generate code for all the inlined subprograms.  */
4704   if (optimize)
4705     {
4706       Entity_Id gnat_entity;
4707
4708       for (gnat_entity = First_Inlined_Subprogram (gnat_node);
4709            Present (gnat_entity);
4710            gnat_entity = Next_Inlined_Subprogram (gnat_entity))
4711         {
4712           Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
4713
4714           if (Nkind (gnat_body) != N_Subprogram_Body)
4715             {
4716               /* ??? This really should always be present.  */
4717               if (No (Corresponding_Body (gnat_body)))
4718                 continue;
4719               gnat_body
4720                 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
4721             }
4722
4723           if (Present (gnat_body))
4724             {
4725               /* Define the entity first so we set DECL_EXTERNAL.  */
4726               gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4727               add_stmt (gnat_to_gnu (gnat_body));
4728             }
4729         }
4730     }
4731
4732   /* Process any pragmas and actions following the unit.  */
4733   add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
4734   add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
4735   finalize_from_with_types ();
4736
4737   /* Save away what we've made so far and record this potential elaboration
4738      procedure.  */
4739   info = ggc_alloc_elab_info ();
4740   set_current_block_context (gnu_elab_proc_decl);
4741   gnat_poplevel ();
4742   DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
4743
4744   set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
4745
4746   info->next = elab_info_list;
4747   info->elab_proc = gnu_elab_proc_decl;
4748   info->gnat_node = gnat_node;
4749   elab_info_list = info;
4750
4751   /* Generate elaboration code for this unit, if necessary, and say whether
4752      we did or not.  */
4753   VEC_pop (tree, gnu_elab_proc_stack);
4754
4755   /* Invalidate the global renaming pointers.  This is necessary because
4756      stabilization of the renamed entities may create SAVE_EXPRs which
4757      have been tied to a specific elaboration routine just above.  */
4758   invalidate_global_renaming_pointers ();
4759 }
4760 \f
4761 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
4762    parameter of a call.  */
4763
4764 static bool
4765 lhs_or_actual_p (Node_Id gnat_node)
4766 {
4767   Node_Id gnat_parent = Parent (gnat_node);
4768   Node_Kind kind = Nkind (gnat_parent);
4769
4770   if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
4771     return true;
4772
4773   if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
4774       && Name (gnat_parent) != gnat_node)
4775     return true;
4776
4777   if (kind == N_Parameter_Association)
4778     return true;
4779
4780   return false;
4781 }
4782
4783 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
4784    of an assignment or an actual parameter of a call.  */
4785
4786 static bool
4787 present_in_lhs_or_actual_p (Node_Id gnat_node)
4788 {
4789   Node_Kind kind;
4790
4791   if (lhs_or_actual_p (gnat_node))
4792     return true;
4793
4794   kind = Nkind (Parent (gnat_node));
4795
4796   if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
4797       && lhs_or_actual_p (Parent (gnat_node)))
4798     return true;
4799
4800   return false;
4801 }
4802
4803 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
4804    as gigi is concerned.  This is used to avoid conversions on the LHS.  */
4805
4806 static bool
4807 unchecked_conversion_nop (Node_Id gnat_node)
4808 {
4809   Entity_Id from_type, to_type;
4810
4811   /* The conversion must be on the LHS of an assignment or an actual parameter
4812      of a call.  Otherwise, even if the conversion was essentially a no-op, it
4813      could de facto ensure type consistency and this should be preserved.  */
4814   if (!lhs_or_actual_p (gnat_node))
4815     return false;
4816
4817   from_type = Etype (Expression (gnat_node));
4818
4819   /* We're interested in artificial conversions generated by the front-end
4820      to make private types explicit, e.g. in Expand_Assign_Array.  */
4821   if (!Is_Private_Type (from_type))
4822     return false;
4823
4824   from_type = Underlying_Type (from_type);
4825   to_type = Etype (gnat_node);
4826
4827   /* The direct conversion to the underlying type is a no-op.  */
4828   if (to_type == from_type)
4829     return true;
4830
4831   /* For an array subtype, the conversion to the PAT is a no-op.  */
4832   if (Ekind (from_type) == E_Array_Subtype
4833       && to_type == Packed_Array_Type (from_type))
4834     return true;
4835
4836   /* For a record subtype, the conversion to the type is a no-op.  */
4837   if (Ekind (from_type) == E_Record_Subtype
4838       && to_type == Etype (from_type))
4839     return true;
4840
4841   return false;
4842 }
4843
4844 /* This function is the driver of the GNAT to GCC tree transformation process.
4845    It is the entry point of the tree transformer.  GNAT_NODE is the root of
4846    some GNAT tree.  Return the root of the corresponding GCC tree.  If this
4847    is an expression, return the GCC equivalent of the expression.  If this
4848    is a statement, return the statement or add it to the current statement
4849    group, in which case anything returned is to be interpreted as occurring
4850    after anything added.  */
4851
4852 tree
4853 gnat_to_gnu (Node_Id gnat_node)
4854 {
4855   const Node_Kind kind = Nkind (gnat_node);
4856   bool went_into_elab_proc = false;
4857   tree gnu_result = error_mark_node; /* Default to no value.  */
4858   tree gnu_result_type = void_type_node;
4859   tree gnu_expr, gnu_lhs, gnu_rhs;
4860   Node_Id gnat_temp;
4861
4862   /* Save node number for error message and set location information.  */
4863   error_gnat_node = gnat_node;
4864   Sloc_to_locus (Sloc (gnat_node), &input_location);
4865
4866   /* If this node is a statement and we are only annotating types, return an
4867      empty statement list.  */
4868   if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
4869     return alloc_stmt_list ();
4870
4871   /* If this node is a non-static subexpression and we are only annotating
4872      types, make this into a NULL_EXPR.  */
4873   if (type_annotate_only
4874       && IN (kind, N_Subexpr)
4875       && kind != N_Identifier
4876       && !Compile_Time_Known_Value (gnat_node))
4877     return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
4878                    build_call_raise (CE_Range_Check_Failed, gnat_node,
4879                                      N_Raise_Constraint_Error));
4880
4881   if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
4882        && kind != N_Null_Statement)
4883       || kind == N_Procedure_Call_Statement
4884       || kind == N_Label
4885       || kind == N_Implicit_Label_Declaration
4886       || kind == N_Handled_Sequence_Of_Statements
4887       || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
4888     {
4889       tree current_elab_proc = get_elaboration_procedure ();
4890
4891       /* If this is a statement and we are at top level, it must be part of
4892          the elaboration procedure, so mark us as being in that procedure.  */
4893       if (!current_function_decl)
4894         {
4895           current_function_decl = current_elab_proc;
4896           went_into_elab_proc = true;
4897         }
4898
4899       /* If we are in the elaboration procedure, check if we are violating a
4900          No_Elaboration_Code restriction by having a statement there.  Don't
4901          check for a possible No_Elaboration_Code restriction violation on
4902          N_Handled_Sequence_Of_Statements, as we want to signal an error on
4903          every nested real statement instead.  This also avoids triggering
4904          spurious errors on dummy (empty) sequences created by the front-end
4905          for package bodies in some cases.  */
4906       if (current_function_decl == current_elab_proc
4907           && kind != N_Handled_Sequence_Of_Statements)
4908         Check_Elaboration_Code_Allowed (gnat_node);
4909     }
4910
4911   switch (kind)
4912     {
4913       /********************************/
4914       /* Chapter 2: Lexical Elements  */
4915       /********************************/
4916
4917     case N_Identifier:
4918     case N_Expanded_Name:
4919     case N_Operator_Symbol:
4920     case N_Defining_Identifier:
4921       gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
4922
4923       /* If this is an atomic access on the RHS for which synchronization is
4924          required, build the atomic load.  */
4925       if (atomic_sync_required_p (gnat_node)
4926           && !present_in_lhs_or_actual_p (gnat_node))
4927         gnu_result = build_atomic_load (gnu_result);
4928       break;
4929
4930     case N_Integer_Literal:
4931       {
4932         tree gnu_type;
4933
4934         /* Get the type of the result, looking inside any padding and
4935            justified modular types.  Then get the value in that type.  */
4936         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
4937
4938         if (TREE_CODE (gnu_type) == RECORD_TYPE
4939             && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
4940           gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
4941
4942         gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
4943
4944         /* If the result overflows (meaning it doesn't fit in its base type),
4945            abort.  We would like to check that the value is within the range
4946            of the subtype, but that causes problems with subtypes whose usage
4947            will raise Constraint_Error and with biased representation, so
4948            we don't.  */
4949         gcc_assert (!TREE_OVERFLOW (gnu_result));
4950       }
4951       break;
4952
4953     case N_Character_Literal:
4954       /* If a Entity is present, it means that this was one of the
4955          literals in a user-defined character type.  In that case,
4956          just return the value in the CONST_DECL.  Otherwise, use the
4957          character code.  In that case, the base type should be an
4958          INTEGER_TYPE, but we won't bother checking for that.  */
4959       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4960       if (Present (Entity (gnat_node)))
4961         gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
4962       else
4963         gnu_result
4964           = build_int_cst_type
4965               (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
4966       break;
4967
4968     case N_Real_Literal:
4969       /* If this is of a fixed-point type, the value we want is the
4970          value of the corresponding integer.  */
4971       if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
4972         {
4973           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4974           gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
4975                                   gnu_result_type);
4976           gcc_assert (!TREE_OVERFLOW (gnu_result));
4977         }
4978
4979       /* We should never see a Vax_Float type literal, since the front end
4980          is supposed to transform these using appropriate conversions.  */
4981       else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
4982         gcc_unreachable ();
4983
4984       else
4985         {
4986           Ureal ur_realval = Realval (gnat_node);
4987
4988           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4989
4990           /* If the real value is zero, so is the result.  Otherwise,
4991              convert it to a machine number if it isn't already.  That
4992              forces BASE to 0 or 2 and simplifies the rest of our logic.  */
4993           if (UR_Is_Zero (ur_realval))
4994             gnu_result = convert (gnu_result_type, integer_zero_node);
4995           else
4996             {
4997               if (!Is_Machine_Number (gnat_node))
4998                 ur_realval
4999                   = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
5000                              ur_realval, Round_Even, gnat_node);
5001
5002               gnu_result
5003                 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
5004
5005               /* If we have a base of zero, divide by the denominator.
5006                  Otherwise, the base must be 2 and we scale the value, which
5007                  we know can fit in the mantissa of the type (hence the use
5008                  of that type above).  */
5009               if (No (Rbase (ur_realval)))
5010                 gnu_result
5011                   = build_binary_op (RDIV_EXPR,
5012                                      get_base_type (gnu_result_type),
5013                                      gnu_result,
5014                                      UI_To_gnu (Denominator (ur_realval),
5015                                                 gnu_result_type));
5016               else
5017                 {
5018                   REAL_VALUE_TYPE tmp;
5019
5020                   gcc_assert (Rbase (ur_realval) == 2);
5021                   real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
5022                               - UI_To_Int (Denominator (ur_realval)));
5023                   gnu_result = build_real (gnu_result_type, tmp);
5024                 }
5025             }
5026
5027           /* Now see if we need to negate the result.  Do it this way to
5028              properly handle -0.  */
5029           if (UR_Is_Negative (Realval (gnat_node)))
5030             gnu_result
5031               = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
5032                                 gnu_result);
5033         }
5034
5035       break;
5036
5037     case N_String_Literal:
5038       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5039       if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
5040         {
5041           String_Id gnat_string = Strval (gnat_node);
5042           int length = String_Length (gnat_string);
5043           int i;
5044           char *string;
5045           if (length >= ALLOCA_THRESHOLD)
5046             string = XNEWVEC (char, length + 1);
5047           else
5048             string = (char *) alloca (length + 1);
5049
5050           /* Build the string with the characters in the literal.  Note
5051              that Ada strings are 1-origin.  */
5052           for (i = 0; i < length; i++)
5053             string[i] = Get_String_Char (gnat_string, i + 1);
5054
5055           /* Put a null at the end of the string in case it's in a context
5056              where GCC will want to treat it as a C string.  */
5057           string[i] = 0;
5058
5059           gnu_result = build_string (length, string);
5060
5061           /* Strings in GCC don't normally have types, but we want
5062              this to not be converted to the array type.  */
5063           TREE_TYPE (gnu_result) = gnu_result_type;
5064
5065           if (length >= ALLOCA_THRESHOLD)
5066             free (string);
5067         }
5068       else
5069         {
5070           /* Build a list consisting of each character, then make
5071              the aggregate.  */
5072           String_Id gnat_string = Strval (gnat_node);
5073           int length = String_Length (gnat_string);
5074           int i;
5075           tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
5076           VEC(constructor_elt,gc) *gnu_vec
5077             = VEC_alloc (constructor_elt, gc, length);
5078
5079           for (i = 0; i < length; i++)
5080             {
5081               tree t = build_int_cst (TREE_TYPE (gnu_result_type),
5082                                       Get_String_Char (gnat_string, i + 1));
5083
5084               CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
5085               gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node);
5086             }
5087
5088           gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
5089         }
5090       break;
5091
5092     case N_Pragma:
5093       gnu_result = Pragma_to_gnu (gnat_node);
5094       break;
5095
5096     /**************************************/
5097     /* Chapter 3: Declarations and Types  */
5098     /**************************************/
5099
5100     case N_Subtype_Declaration:
5101     case N_Full_Type_Declaration:
5102     case N_Incomplete_Type_Declaration:
5103     case N_Private_Type_Declaration:
5104     case N_Private_Extension_Declaration:
5105     case N_Task_Type_Declaration:
5106       process_type (Defining_Entity (gnat_node));
5107       gnu_result = alloc_stmt_list ();
5108       break;
5109
5110     case N_Object_Declaration:
5111     case N_Exception_Declaration:
5112       gnat_temp = Defining_Entity (gnat_node);
5113       gnu_result = alloc_stmt_list ();
5114
5115       /* If we are just annotating types and this object has an unconstrained
5116          or task type, don't elaborate it.   */
5117       if (type_annotate_only
5118           && (((Is_Array_Type (Etype (gnat_temp))
5119                 || Is_Record_Type (Etype (gnat_temp)))
5120                && !Is_Constrained (Etype (gnat_temp)))
5121             || Is_Concurrent_Type (Etype (gnat_temp))))
5122         break;
5123
5124       if (Present (Expression (gnat_node))
5125           && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
5126           && (!type_annotate_only
5127               || Compile_Time_Known_Value (Expression (gnat_node))))
5128         {
5129           gnu_expr = gnat_to_gnu (Expression (gnat_node));
5130           if (Do_Range_Check (Expression (gnat_node)))
5131             gnu_expr
5132               = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
5133
5134           /* If this object has its elaboration delayed, we must force
5135              evaluation of GNU_EXPR right now and save it for when the object
5136              is frozen.  */
5137           if (Present (Freeze_Node (gnat_temp)))
5138             {
5139               if (TREE_CONSTANT (gnu_expr))
5140                 ;
5141               else if (global_bindings_p ())
5142                 gnu_expr
5143                   = create_var_decl (create_concat_name (gnat_temp, "init"),
5144                                      NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5145                                      false, false, false, false,
5146                                      NULL, gnat_temp);
5147               else
5148                 gnu_expr = gnat_save_expr (gnu_expr);
5149
5150               save_gnu_tree (gnat_node, gnu_expr, true);
5151             }
5152         }
5153       else
5154         gnu_expr = NULL_TREE;
5155
5156       if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
5157         gnu_expr = NULL_TREE;
5158
5159       /* If this is a deferred constant with an address clause, we ignore the
5160          full view since the clause is on the partial view and we cannot have
5161          2 different GCC trees for the object.  The only bits of the full view
5162          we will use is the initializer, but it will be directly fetched.  */
5163       if (Ekind(gnat_temp) == E_Constant
5164           && Present (Address_Clause (gnat_temp))
5165           && Present (Full_View (gnat_temp)))
5166         save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
5167
5168       if (No (Freeze_Node (gnat_temp)))
5169         gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
5170       break;
5171
5172     case N_Object_Renaming_Declaration:
5173       gnat_temp = Defining_Entity (gnat_node);
5174
5175       /* Don't do anything if this renaming is handled by the front end or if
5176          we are just annotating types and this object has a composite or task
5177          type, don't elaborate it.  We return the result in case it has any
5178          SAVE_EXPRs in it that need to be evaluated here.  */
5179       if (!Is_Renaming_Of_Object (gnat_temp)
5180           && ! (type_annotate_only
5181                 && (Is_Array_Type (Etype (gnat_temp))
5182                     || Is_Record_Type (Etype (gnat_temp))
5183                     || Is_Concurrent_Type (Etype (gnat_temp)))))
5184         gnu_result
5185           = gnat_to_gnu_entity (gnat_temp,
5186                                 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
5187       else
5188         gnu_result = alloc_stmt_list ();
5189       break;
5190
5191     case N_Implicit_Label_Declaration:
5192       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
5193       gnu_result = alloc_stmt_list ();
5194       break;
5195
5196     case N_Exception_Renaming_Declaration:
5197     case N_Number_Declaration:
5198     case N_Package_Renaming_Declaration:
5199     case N_Subprogram_Renaming_Declaration:
5200       /* These are fully handled in the front end.  */
5201       gnu_result = alloc_stmt_list ();
5202       break;
5203
5204     /*************************************/
5205     /* Chapter 4: Names and Expressions  */
5206     /*************************************/
5207
5208     case N_Explicit_Dereference:
5209       gnu_result = gnat_to_gnu (Prefix (gnat_node));
5210       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5211       gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
5212
5213       /* If this is an atomic access on the RHS for which synchronization is
5214          required, build the atomic load.  */
5215       if (atomic_sync_required_p (gnat_node)
5216           && !present_in_lhs_or_actual_p (gnat_node))
5217         gnu_result = build_atomic_load (gnu_result);
5218       break;
5219
5220     case N_Indexed_Component:
5221       {
5222         tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
5223         tree gnu_type;
5224         int ndim;
5225         int i;
5226         Node_Id *gnat_expr_array;
5227
5228         gnu_array_object = maybe_implicit_deref (gnu_array_object);
5229
5230         /* Convert vector inputs to their representative array type, to fit
5231            what the code below expects.  */
5232         if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object)))
5233           {
5234             if (present_in_lhs_or_actual_p (gnat_node))
5235               gnat_mark_addressable (gnu_array_object);
5236             gnu_array_object = maybe_vector_array (gnu_array_object);
5237           }
5238
5239         gnu_array_object = maybe_unconstrained_array (gnu_array_object);
5240
5241         /* If we got a padded type, remove it too.  */
5242         if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
5243           gnu_array_object
5244             = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
5245                        gnu_array_object);
5246
5247         gnu_result = gnu_array_object;
5248
5249         /* First compute the number of dimensions of the array, then
5250            fill the expression array, the order depending on whether
5251            this is a Convention_Fortran array or not.  */
5252         for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
5253              TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5254              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
5255              ndim++, gnu_type = TREE_TYPE (gnu_type))
5256           ;
5257
5258         gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
5259
5260         if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
5261           for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
5262                i >= 0;
5263                i--, gnat_temp = Next (gnat_temp))
5264             gnat_expr_array[i] = gnat_temp;
5265         else
5266           for (i = 0, gnat_temp = First (Expressions (gnat_node));
5267                i < ndim;
5268                i++, gnat_temp = Next (gnat_temp))
5269             gnat_expr_array[i] = gnat_temp;
5270
5271         for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
5272              i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
5273           {
5274             gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
5275             gnat_temp = gnat_expr_array[i];
5276             gnu_expr = gnat_to_gnu (gnat_temp);
5277
5278             if (Do_Range_Check (gnat_temp))
5279               gnu_expr
5280                 = emit_index_check
5281                   (gnu_array_object, gnu_expr,
5282                    TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
5283                    TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
5284                    gnat_temp);
5285
5286             gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
5287                                           gnu_result, gnu_expr);
5288           }
5289
5290         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5291
5292         /* If this is an atomic access on the RHS for which synchronization is
5293            required, build the atomic load.  */
5294         if (atomic_sync_required_p (gnat_node)
5295             && !present_in_lhs_or_actual_p (gnat_node))
5296           gnu_result = build_atomic_load (gnu_result);
5297       }
5298       break;
5299
5300     case N_Slice:
5301       {
5302         Node_Id gnat_range_node = Discrete_Range (gnat_node);
5303         tree gnu_type;
5304
5305         gnu_result = gnat_to_gnu (Prefix (gnat_node));
5306         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5307
5308         /* Do any implicit dereferences of the prefix and do any needed
5309            range check.  */
5310         gnu_result = maybe_implicit_deref (gnu_result);
5311         gnu_result = maybe_unconstrained_array (gnu_result);
5312         gnu_type = TREE_TYPE (gnu_result);
5313         if (Do_Range_Check (gnat_range_node))
5314           {
5315             /* Get the bounds of the slice.  */
5316             tree gnu_index_type
5317               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
5318             tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
5319             tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
5320             /* Get the permitted bounds.  */
5321             tree gnu_base_index_type
5322               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
5323             tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
5324               (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
5325             tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
5326               (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
5327             tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
5328
5329            gnu_min_expr = gnat_protect_expr (gnu_min_expr);
5330            gnu_max_expr = gnat_protect_expr (gnu_max_expr);
5331
5332             /* Derive a good type to convert everything to.  */
5333             gnu_expr_type = get_base_type (gnu_index_type);
5334
5335             /* Test whether the minimum slice value is too small.  */
5336             gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
5337                                           convert (gnu_expr_type,
5338                                                    gnu_min_expr),
5339                                           convert (gnu_expr_type,
5340                                                    gnu_base_min_expr));
5341
5342             /* Test whether the maximum slice value is too large.  */
5343             gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
5344                                           convert (gnu_expr_type,
5345                                                    gnu_max_expr),
5346                                           convert (gnu_expr_type,
5347                                                    gnu_base_max_expr));
5348
5349             /* Build a slice index check that returns the low bound,
5350                assuming the slice is not empty.  */
5351             gnu_expr = emit_check
5352               (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
5353                                 gnu_expr_l, gnu_expr_h),
5354                gnu_min_expr, CE_Index_Check_Failed, gnat_node);
5355
5356            /* Build a conditional expression that does the index checks and
5357               returns the low bound if the slice is not empty (max >= min),
5358               and returns the naked low bound otherwise (max < min), unless
5359               it is non-constant and the high bound is; this prevents VRP
5360               from inferring bogus ranges on the unlikely path.  */
5361             gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
5362                                     build_binary_op (GE_EXPR, gnu_expr_type,
5363                                                      convert (gnu_expr_type,
5364                                                               gnu_max_expr),
5365                                                      convert (gnu_expr_type,
5366                                                               gnu_min_expr)),
5367                                     gnu_expr,
5368                                     TREE_CODE (gnu_min_expr) != INTEGER_CST
5369                                     && TREE_CODE (gnu_max_expr) == INTEGER_CST
5370                                     ? gnu_max_expr : gnu_min_expr);
5371           }
5372         else
5373           /* Simply return the naked low bound.  */
5374           gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
5375
5376         /* If this is a slice with non-constant size of an array with constant
5377            size, set the maximum size for the allocation of temporaries.  */
5378         if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
5379             && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
5380           TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
5381
5382         gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
5383                                       gnu_result, gnu_expr);
5384       }
5385       break;
5386
5387     case N_Selected_Component:
5388       {
5389         tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
5390         Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
5391         Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
5392         tree gnu_field;
5393
5394         while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
5395                || IN (Ekind (gnat_pref_type), Access_Kind))
5396           {
5397             if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
5398               gnat_pref_type = Underlying_Type (gnat_pref_type);
5399             else if (IN (Ekind (gnat_pref_type), Access_Kind))
5400               gnat_pref_type = Designated_Type (gnat_pref_type);
5401           }
5402
5403         gnu_prefix = maybe_implicit_deref (gnu_prefix);
5404
5405         /* For discriminant references in tagged types always substitute the
5406            corresponding discriminant as the actual selected component.  */
5407         if (Is_Tagged_Type (gnat_pref_type))
5408           while (Present (Corresponding_Discriminant (gnat_field)))
5409             gnat_field = Corresponding_Discriminant (gnat_field);
5410
5411         /* For discriminant references of untagged types always substitute the
5412            corresponding stored discriminant.  */
5413         else if (Present (Corresponding_Discriminant (gnat_field)))
5414           gnat_field = Original_Record_Component (gnat_field);
5415
5416         /* Handle extracting the real or imaginary part of a complex.
5417            The real part is the first field and the imaginary the last.  */
5418         if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
5419           gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
5420                                        ? REALPART_EXPR : IMAGPART_EXPR,
5421                                        NULL_TREE, gnu_prefix);
5422         else
5423           {
5424             gnu_field = gnat_to_gnu_field_decl (gnat_field);
5425
5426             /* If there are discriminants, the prefix might be evaluated more
5427                than once, which is a problem if it has side-effects.  */
5428             if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
5429                                    ? Designated_Type (Etype
5430                                                       (Prefix (gnat_node)))
5431                                    : Etype (Prefix (gnat_node))))
5432               gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL);
5433
5434             gnu_result
5435               = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
5436                                      (Nkind (Parent (gnat_node))
5437                                       == N_Attribute_Reference)
5438                                      && lvalue_required_for_attribute_p
5439                                         (Parent (gnat_node)));
5440           }
5441
5442         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5443
5444         /* If this is an atomic access on the RHS for which synchronization is
5445            required, build the atomic load.  */
5446         if (atomic_sync_required_p (gnat_node)
5447             && !present_in_lhs_or_actual_p (gnat_node))
5448           gnu_result = build_atomic_load (gnu_result);
5449       }
5450       break;
5451
5452     case N_Attribute_Reference:
5453       {
5454         /* The attribute designator.  */
5455         const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
5456
5457         /* The Elab_Spec and Elab_Body attributes are special in that Prefix
5458            is a unit, not an object with a GCC equivalent.  */
5459         if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
5460           return
5461             create_subprog_decl (create_concat_name
5462                                  (Entity (Prefix (gnat_node)),
5463                                   attr == Attr_Elab_Body ? "elabb" : "elabs"),
5464                                  NULL_TREE, void_ftype, NULL_TREE, false,
5465                                  true, true, true, NULL, gnat_node);
5466
5467         gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
5468       }
5469       break;
5470
5471     case N_Reference:
5472       /* Like 'Access as far as we are concerned.  */
5473       gnu_result = gnat_to_gnu (Prefix (gnat_node));
5474       gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
5475       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5476       break;
5477
5478     case N_Aggregate:
5479     case N_Extension_Aggregate:
5480       {
5481         tree gnu_aggr_type;
5482
5483         /* ??? It is wrong to evaluate the type now, but there doesn't
5484            seem to be any other practical way of doing it.  */
5485
5486         gcc_assert (!Expansion_Delayed (gnat_node));
5487
5488         gnu_aggr_type = gnu_result_type
5489           = get_unpadded_type (Etype (gnat_node));
5490
5491         if (TREE_CODE (gnu_result_type) == RECORD_TYPE
5492             && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
5493           gnu_aggr_type
5494             = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type)));
5495         else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
5496           gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
5497
5498         if (Null_Record_Present (gnat_node))
5499           gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
5500
5501         else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
5502                  || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
5503           gnu_result
5504             = assoc_to_constructor (Etype (gnat_node),
5505                                     First (Component_Associations (gnat_node)),
5506                                     gnu_aggr_type);
5507         else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
5508           gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
5509                                            gnu_aggr_type,
5510                                            Component_Type (Etype (gnat_node)));
5511         else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
5512           gnu_result
5513             = build_binary_op
5514               (COMPLEX_EXPR, gnu_aggr_type,
5515                gnat_to_gnu (Expression (First
5516                                         (Component_Associations (gnat_node)))),
5517                gnat_to_gnu (Expression
5518                             (Next
5519                              (First (Component_Associations (gnat_node))))));
5520         else
5521           gcc_unreachable ();
5522
5523         gnu_result = convert (gnu_result_type, gnu_result);
5524       }
5525       break;
5526
5527     case N_Null:
5528       if (TARGET_VTABLE_USES_DESCRIPTORS
5529           && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
5530           && Is_Dispatch_Table_Entity (Etype (gnat_node)))
5531         gnu_result = null_fdesc_node;
5532       else
5533         gnu_result = null_pointer_node;
5534       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5535       break;
5536
5537     case N_Type_Conversion:
5538     case N_Qualified_Expression:
5539       /* Get the operand expression.  */
5540       gnu_result = gnat_to_gnu (Expression (gnat_node));
5541       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5542
5543       /* If this is a qualified expression for a tagged type, we mark the type
5544          as used.  Because of polymorphism, this might be the only reference to
5545          the tagged type in the program while objects have it as dynamic type.
5546          The debugger needs to see it to display these objects properly.  */
5547       if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
5548         used_types_insert (gnu_result_type);
5549
5550       gnu_result
5551         = convert_with_check (Etype (gnat_node), gnu_result,
5552                               Do_Overflow_Check (gnat_node),
5553                               Do_Range_Check (Expression (gnat_node)),
5554                               kind == N_Type_Conversion
5555                               && Float_Truncate (gnat_node), gnat_node);
5556       break;
5557
5558     case N_Unchecked_Type_Conversion:
5559       gnu_result = gnat_to_gnu (Expression (gnat_node));
5560
5561       /* Skip further processing if the conversion is deemed a no-op.  */
5562       if (unchecked_conversion_nop (gnat_node))
5563         {
5564           gnu_result_type = TREE_TYPE (gnu_result);
5565           break;
5566         }
5567
5568       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5569
5570       /* If the result is a pointer type, see if we are improperly
5571          converting to a stricter alignment.  */
5572       if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
5573           && IN (Ekind (Etype (gnat_node)), Access_Kind))
5574         {
5575           unsigned int align = known_alignment (gnu_result);
5576           tree gnu_obj_type = TREE_TYPE (gnu_result_type);
5577           unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
5578
5579           if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
5580             post_error_ne_tree_2
5581               ("?source alignment (^) '< alignment of & (^)",
5582                gnat_node, Designated_Type (Etype (gnat_node)),
5583                size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
5584         }
5585
5586       /* If we are converting a descriptor to a function pointer, first
5587          build the pointer.  */
5588       if (TARGET_VTABLE_USES_DESCRIPTORS
5589           && TREE_TYPE (gnu_result) == fdesc_type_node
5590           && POINTER_TYPE_P (gnu_result_type))
5591         gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
5592
5593       gnu_result = unchecked_convert (gnu_result_type, gnu_result,
5594                                       No_Truncation (gnat_node));
5595       break;
5596
5597     case N_In:
5598     case N_Not_In:
5599       {
5600         tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
5601         Node_Id gnat_range = Right_Opnd (gnat_node);
5602         tree gnu_low, gnu_high;
5603
5604         /* GNAT_RANGE is either an N_Range node or an identifier denoting a
5605            subtype.  */
5606         if (Nkind (gnat_range) == N_Range)
5607           {
5608             gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
5609             gnu_high = gnat_to_gnu (High_Bound (gnat_range));
5610           }
5611         else if (Nkind (gnat_range) == N_Identifier
5612                  || Nkind (gnat_range) == N_Expanded_Name)
5613           {
5614             tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
5615
5616             gnu_low = TYPE_MIN_VALUE (gnu_range_type);
5617             gnu_high = TYPE_MAX_VALUE (gnu_range_type);
5618           }
5619         else
5620           gcc_unreachable ();
5621
5622         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5623
5624         /* If LOW and HIGH are identical, perform an equality test.  Otherwise,
5625            ensure that GNU_OBJ is evaluated only once and perform a full range
5626            test.  */
5627         if (operand_equal_p (gnu_low, gnu_high, 0))
5628           gnu_result
5629             = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
5630         else
5631           {
5632             tree t1, t2;
5633             gnu_obj = gnat_protect_expr (gnu_obj);
5634             t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
5635             if (EXPR_P (t1))
5636               set_expr_location_from_node (t1, gnat_node);
5637             t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
5638             if (EXPR_P (t2))
5639               set_expr_location_from_node (t2, gnat_node);
5640             gnu_result
5641               = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
5642           }
5643
5644         if (kind == N_Not_In)
5645           gnu_result
5646             = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
5647       }
5648       break;
5649
5650     case N_Op_Divide:
5651       gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
5652       gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
5653       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5654       gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
5655                                     ? RDIV_EXPR
5656                                     : (Rounded_Result (gnat_node)
5657                                        ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
5658                                     gnu_result_type, gnu_lhs, gnu_rhs);
5659       break;
5660
5661     case N_Op_Or:    case N_Op_And:      case N_Op_Xor:
5662       /* These can either be operations on booleans or on modular types.
5663          Fall through for boolean types since that's the way GNU_CODES is
5664          set up.  */
5665       if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
5666               Modular_Integer_Kind))
5667         {
5668           enum tree_code code
5669             = (kind == N_Op_Or ? BIT_IOR_EXPR
5670                : kind == N_Op_And ? BIT_AND_EXPR
5671                : BIT_XOR_EXPR);
5672
5673           gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
5674           gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
5675           gnu_result_type = get_unpadded_type (Etype (gnat_node));
5676           gnu_result = build_binary_op (code, gnu_result_type,
5677                                         gnu_lhs, gnu_rhs);
5678           break;
5679         }
5680
5681       /* ... fall through ... */
5682
5683     case N_Op_Eq:    case N_Op_Ne:       case N_Op_Lt:
5684     case N_Op_Le:    case N_Op_Gt:       case N_Op_Ge:
5685     case N_Op_Add:   case N_Op_Subtract: case N_Op_Multiply:
5686     case N_Op_Mod:   case N_Op_Rem:
5687     case N_Op_Rotate_Left:
5688     case N_Op_Rotate_Right:
5689     case N_Op_Shift_Left:
5690     case N_Op_Shift_Right:
5691     case N_Op_Shift_Right_Arithmetic:
5692     case N_And_Then: case N_Or_Else:
5693       {
5694         enum tree_code code = gnu_codes[kind];
5695         bool ignore_lhs_overflow = false;
5696         location_t saved_location = input_location;
5697         tree gnu_type;
5698
5699         gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
5700         gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
5701         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
5702
5703         /* Pending generic support for efficient vector logical operations in
5704            GCC, convert vectors to their representative array type view and
5705            fallthrough.  */
5706         gnu_lhs = maybe_vector_array (gnu_lhs);
5707         gnu_rhs = maybe_vector_array (gnu_rhs);
5708
5709         /* If this is a comparison operator, convert any references to
5710            an unconstrained array value into a reference to the
5711            actual array.  */
5712         if (TREE_CODE_CLASS (code) == tcc_comparison)
5713           {
5714             gnu_lhs = maybe_unconstrained_array (gnu_lhs);
5715             gnu_rhs = maybe_unconstrained_array (gnu_rhs);
5716           }
5717
5718         /* If the result type is a private type, its full view may be a
5719            numeric subtype. The representation we need is that of its base
5720            type, given that it is the result of an arithmetic operation.  */
5721         else if (Is_Private_Type (Etype (gnat_node)))
5722           gnu_type = gnu_result_type
5723             = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
5724
5725         /* If this is a shift whose count is not guaranteed to be correct,
5726            we need to adjust the shift count.  */
5727         if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
5728           {
5729             tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
5730             tree gnu_max_shift
5731               = convert (gnu_count_type, TYPE_SIZE (gnu_type));
5732
5733             if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
5734               gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
5735                                          gnu_rhs, gnu_max_shift);
5736             else if (kind == N_Op_Shift_Right_Arithmetic)
5737               gnu_rhs
5738                 = build_binary_op
5739                   (MIN_EXPR, gnu_count_type,
5740                    build_binary_op (MINUS_EXPR,
5741                                     gnu_count_type,
5742                                     gnu_max_shift,
5743                                     convert (gnu_count_type,
5744                                              integer_one_node)),
5745                    gnu_rhs);
5746           }
5747
5748         /* For right shifts, the type says what kind of shift to do,
5749            so we may need to choose a different type.  In this case,
5750            we have to ignore integer overflow lest it propagates all
5751            the way down and causes a CE to be explicitly raised.  */
5752         if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
5753           {
5754             gnu_type = gnat_unsigned_type (gnu_type);
5755             ignore_lhs_overflow = true;
5756           }
5757         else if (kind == N_Op_Shift_Right_Arithmetic
5758                  && TYPE_UNSIGNED (gnu_type))
5759           {
5760             gnu_type = gnat_signed_type (gnu_type);
5761             ignore_lhs_overflow = true;
5762           }
5763
5764         if (gnu_type != gnu_result_type)
5765           {
5766             tree gnu_old_lhs = gnu_lhs;
5767             gnu_lhs = convert (gnu_type, gnu_lhs);
5768             if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
5769               TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
5770             gnu_rhs = convert (gnu_type, gnu_rhs);
5771           }
5772
5773         /* Instead of expanding overflow checks for addition, subtraction
5774            and multiplication itself, the front end will leave this to
5775            the back end when Backend_Overflow_Checks_On_Target is set.
5776            As the GCC back end itself does not know yet how to properly
5777            do overflow checking, do it here.  The goal is to push
5778            the expansions further into the back end over time.  */
5779         if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
5780             && (kind == N_Op_Add
5781                 || kind == N_Op_Subtract
5782                 || kind == N_Op_Multiply)
5783             && !TYPE_UNSIGNED (gnu_type)
5784             && !FLOAT_TYPE_P (gnu_type))
5785           gnu_result = build_binary_op_trapv (code, gnu_type,
5786                                               gnu_lhs, gnu_rhs, gnat_node);
5787         else
5788           {
5789             /* Some operations, e.g. comparisons of arrays, generate complex
5790                trees that need to be annotated while they are being built.  */
5791             input_location = saved_location;
5792             gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
5793           }
5794
5795         /* If this is a logical shift with the shift count not verified,
5796            we must return zero if it is too large.  We cannot compensate
5797            above in this case.  */
5798         if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
5799             && !Shift_Count_OK (gnat_node))
5800           gnu_result
5801             = build_cond_expr
5802               (gnu_type,
5803                build_binary_op (GE_EXPR, boolean_type_node,
5804                                 gnu_rhs,
5805                                 convert (TREE_TYPE (gnu_rhs),
5806                                          TYPE_SIZE (gnu_type))),
5807                convert (gnu_type, integer_zero_node),
5808                gnu_result);
5809       }
5810       break;
5811
5812     case N_Conditional_Expression:
5813       {
5814         tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
5815         tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
5816         tree gnu_false
5817           = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
5818
5819         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5820         gnu_result
5821           = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
5822       }
5823       break;
5824
5825     case N_Op_Plus:
5826       gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
5827       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5828       break;
5829
5830     case N_Op_Not:
5831       /* This case can apply to a boolean or a modular type.
5832          Fall through for a boolean operand since GNU_CODES is set
5833          up to handle this.  */
5834       if (Is_Modular_Integer_Type (Etype (gnat_node))
5835           || (Ekind (Etype (gnat_node)) == E_Private_Type
5836               && Is_Modular_Integer_Type (Full_View (Etype (gnat_node)))))
5837         {
5838           gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
5839           gnu_result_type = get_unpadded_type (Etype (gnat_node));
5840           gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
5841                                        gnu_expr);
5842           break;
5843         }
5844
5845       /* ... fall through ... */
5846
5847     case N_Op_Minus:  case N_Op_Abs:
5848       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
5849
5850       if (Ekind (Etype (gnat_node)) != E_Private_Type)
5851         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5852       else
5853         gnu_result_type = get_unpadded_type (Base_Type
5854                                              (Full_View (Etype (gnat_node))));
5855
5856       if (Do_Overflow_Check (gnat_node)
5857           && !TYPE_UNSIGNED (gnu_result_type)
5858           && !FLOAT_TYPE_P (gnu_result_type))
5859         gnu_result
5860           = build_unary_op_trapv (gnu_codes[kind],
5861                                   gnu_result_type, gnu_expr, gnat_node);
5862       else
5863         gnu_result = build_unary_op (gnu_codes[kind],
5864                                      gnu_result_type, gnu_expr);
5865       break;
5866
5867     case N_Allocator:
5868       {
5869         tree gnu_init = 0;
5870         tree gnu_type;
5871         bool ignore_init_type = false;
5872
5873         gnat_temp = Expression (gnat_node);
5874
5875         /* The Expression operand can either be an N_Identifier or
5876            Expanded_Name, which must represent a type, or a
5877            N_Qualified_Expression, which contains both the object type and an
5878            initial value for the object.  */
5879         if (Nkind (gnat_temp) == N_Identifier
5880             || Nkind (gnat_temp) == N_Expanded_Name)
5881           gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
5882         else if (Nkind (gnat_temp) == N_Qualified_Expression)
5883           {
5884             Entity_Id gnat_desig_type
5885               = Designated_Type (Underlying_Type (Etype (gnat_node)));
5886
5887             ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
5888             gnu_init = gnat_to_gnu (Expression (gnat_temp));
5889
5890             gnu_init = maybe_unconstrained_array (gnu_init);
5891             if (Do_Range_Check (Expression (gnat_temp)))
5892               gnu_init
5893                 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
5894
5895             if (Is_Elementary_Type (gnat_desig_type)
5896                 || Is_Constrained (gnat_desig_type))
5897               gnu_type = gnat_to_gnu_type (gnat_desig_type);
5898             else
5899               {
5900                 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
5901                 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
5902                   gnu_type = TREE_TYPE (gnu_init);
5903               }
5904
5905             /* See the N_Qualified_Expression case for the rationale.  */
5906             if (Is_Tagged_Type (gnat_desig_type))
5907               used_types_insert (gnu_type);
5908
5909             gnu_init = convert (gnu_type, gnu_init);
5910           }
5911         else
5912           gcc_unreachable ();
5913
5914         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5915         return build_allocator (gnu_type, gnu_init, gnu_result_type,
5916                                 Procedure_To_Call (gnat_node),
5917                                 Storage_Pool (gnat_node), gnat_node,
5918                                 ignore_init_type);
5919       }
5920       break;
5921
5922     /**************************/
5923     /* Chapter 5: Statements  */
5924     /**************************/
5925
5926     case N_Label:
5927       gnu_result = build1 (LABEL_EXPR, void_type_node,
5928                            gnat_to_gnu (Identifier (gnat_node)));
5929       break;
5930
5931     case N_Null_Statement:
5932       /* When not optimizing, turn null statements from source into gotos to
5933          the next statement that the middle-end knows how to preserve.  */
5934       if (!optimize && Comes_From_Source (gnat_node))
5935         {
5936           tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
5937           DECL_IGNORED_P (label) = 1;
5938           start_stmt_group ();
5939           stmt = build1 (GOTO_EXPR, void_type_node, label);
5940           set_expr_location_from_node (stmt, gnat_node);
5941           add_stmt (stmt);
5942           stmt = build1 (LABEL_EXPR, void_type_node, label);
5943           set_expr_location_from_node (stmt, gnat_node);
5944           add_stmt (stmt);
5945           gnu_result = end_stmt_group ();
5946         }
5947       else
5948         gnu_result = alloc_stmt_list ();
5949       break;
5950
5951     case N_Assignment_Statement:
5952       /* Get the LHS and RHS of the statement and convert any reference to an
5953          unconstrained array into a reference to the underlying array.  */
5954       gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
5955
5956       /* If the type has a size that overflows, convert this into raise of
5957          Storage_Error: execution shouldn't have gotten here anyway.  */
5958       if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
5959            && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
5960         gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
5961                                        N_Raise_Storage_Error);
5962       else if (Nkind (Expression (gnat_node)) == N_Function_Call)
5963         gnu_result
5964           = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
5965                          atomic_sync_required_p (Name (gnat_node)));
5966       else
5967         {
5968           gnu_rhs
5969             = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
5970
5971           /* If range check is needed, emit code to generate it.  */
5972           if (Do_Range_Check (Expression (gnat_node)))
5973             gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
5974                                         gnat_node);
5975
5976           if (atomic_sync_required_p (Name (gnat_node)))
5977             gnu_result = build_atomic_store (gnu_lhs, gnu_rhs);
5978           else
5979             gnu_result
5980               = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
5981
5982           /* If the type being assigned is an array type and the two sides are
5983              not completely disjoint, play safe and use memmove.  But don't do
5984              it for a bit-packed array as it might not be byte-aligned.  */
5985           if (TREE_CODE (gnu_result) == MODIFY_EXPR
5986               && Is_Array_Type (Etype (Name (gnat_node)))
5987               && !Is_Bit_Packed_Array (Etype (Name (gnat_node)))
5988               && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
5989             {
5990               tree to, from, size, to_ptr, from_ptr, t;
5991
5992               to = TREE_OPERAND (gnu_result, 0);
5993               from = TREE_OPERAND (gnu_result, 1);
5994
5995               size = TYPE_SIZE_UNIT (TREE_TYPE (from));
5996               size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from);
5997
5998               to_ptr = build_fold_addr_expr (to);
5999               from_ptr = build_fold_addr_expr (from);
6000
6001               t = builtin_decl_implicit (BUILT_IN_MEMMOVE);
6002               gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
6003            }
6004         }
6005       break;
6006
6007     case N_If_Statement:
6008       {
6009         tree *gnu_else_ptr; /* Point to put next "else if" or "else".  */
6010
6011         /* Make the outer COND_EXPR.  Avoid non-determinism.  */
6012         gnu_result = build3 (COND_EXPR, void_type_node,
6013                              gnat_to_gnu (Condition (gnat_node)),
6014                              NULL_TREE, NULL_TREE);
6015         COND_EXPR_THEN (gnu_result)
6016           = build_stmt_group (Then_Statements (gnat_node), false);
6017         TREE_SIDE_EFFECTS (gnu_result) = 1;
6018         gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
6019
6020         /* Now make a COND_EXPR for each of the "else if" parts.  Put each
6021            into the previous "else" part and point to where to put any
6022            outer "else".  Also avoid non-determinism.  */
6023         if (Present (Elsif_Parts (gnat_node)))
6024           for (gnat_temp = First (Elsif_Parts (gnat_node));
6025                Present (gnat_temp); gnat_temp = Next (gnat_temp))
6026             {
6027               gnu_expr = build3 (COND_EXPR, void_type_node,
6028                                  gnat_to_gnu (Condition (gnat_temp)),
6029                                  NULL_TREE, NULL_TREE);
6030               COND_EXPR_THEN (gnu_expr)
6031                 = build_stmt_group (Then_Statements (gnat_temp), false);
6032               TREE_SIDE_EFFECTS (gnu_expr) = 1;
6033               set_expr_location_from_node (gnu_expr, gnat_temp);
6034               *gnu_else_ptr = gnu_expr;
6035               gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
6036             }
6037
6038         *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
6039       }
6040       break;
6041
6042     case N_Case_Statement:
6043       gnu_result = Case_Statement_to_gnu (gnat_node);
6044       break;
6045
6046     case N_Loop_Statement:
6047       gnu_result = Loop_Statement_to_gnu (gnat_node);
6048       break;
6049
6050     case N_Block_Statement:
6051       start_stmt_group ();
6052       gnat_pushlevel ();
6053       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
6054       add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
6055       gnat_poplevel ();
6056       gnu_result = end_stmt_group ();
6057
6058       if (Present (Identifier (gnat_node)))
6059         mark_out_of_scope (Entity (Identifier (gnat_node)));
6060       break;
6061
6062     case N_Exit_Statement:
6063       gnu_result
6064         = build2 (EXIT_STMT, void_type_node,
6065                   (Present (Condition (gnat_node))
6066                    ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
6067                   (Present (Name (gnat_node))
6068                    ? get_gnu_tree (Entity (Name (gnat_node)))
6069                    : VEC_last (loop_info, gnu_loop_stack)->label));
6070       break;
6071
6072     case N_Return_Statement:
6073       {
6074         tree gnu_ret_obj, gnu_ret_val;
6075
6076         /* If the subprogram is a function, we must return the expression.  */
6077         if (Present (Expression (gnat_node)))
6078           {
6079             tree gnu_subprog_type = TREE_TYPE (current_function_decl);
6080
6081             /* If this function has copy-in/copy-out parameters, get the real
6082                object for the return.  See Subprogram_to_gnu.  */
6083             if (TYPE_CI_CO_LIST (gnu_subprog_type))
6084               gnu_ret_obj = VEC_last (tree, gnu_return_var_stack);
6085             else
6086               gnu_ret_obj = DECL_RESULT (current_function_decl);
6087
6088             /* Get the GCC tree for the expression to be returned.  */
6089             gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
6090
6091             /* Do not remove the padding from GNU_RET_VAL if the inner type is
6092                self-referential since we want to allocate the fixed size.  */
6093             if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
6094                 && TYPE_IS_PADDING_P
6095                    (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
6096                 && CONTAINS_PLACEHOLDER_P
6097                    (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
6098               gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
6099
6100             /* If the function returns by direct reference, return a pointer
6101                to the return value.  */
6102             if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
6103                 || By_Ref (gnat_node))
6104               gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
6105
6106             /* Otherwise, if it returns an unconstrained array, we have to
6107                allocate a new version of the result and return it.  */
6108             else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
6109               {
6110                 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
6111
6112                 /* And find out whether this is a candidate for Named Return
6113                    Value.  If so, record it.  */
6114                 if (!TYPE_CI_CO_LIST (gnu_subprog_type) && optimize)
6115                   {
6116                     tree ret_val = gnu_ret_val;
6117
6118                     /* Strip useless conversions around the return value.  */
6119                     if (gnat_useless_type_conversion (ret_val))
6120                       ret_val = TREE_OPERAND (ret_val, 0);
6121
6122                     /* Strip unpadding around the return value.  */
6123                     if (TREE_CODE (ret_val) == COMPONENT_REF
6124                         && TYPE_IS_PADDING_P
6125                            (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
6126                       ret_val = TREE_OPERAND (ret_val, 0);
6127
6128                     /* Now apply the test to the return value.  */
6129                     if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
6130                       {
6131                         if (!f_named_ret_val)
6132                           f_named_ret_val = BITMAP_GGC_ALLOC ();
6133                         bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
6134                         if (!f_gnat_ret)
6135                           f_gnat_ret = gnat_node;
6136                       }
6137                   }
6138
6139                 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
6140                                                gnu_ret_val,
6141                                                TREE_TYPE (gnu_ret_obj),
6142                                                Procedure_To_Call (gnat_node),
6143                                                Storage_Pool (gnat_node),
6144                                                gnat_node, false);
6145               }
6146
6147             /* Otherwise, if it returns by invisible reference, dereference
6148                the pointer it is passed using the type of the return value
6149                and build the copy operation manually.  This ensures that we
6150                don't copy too much data, for example if the return type is
6151                unconstrained with a maximum size.  */
6152             else if (TREE_ADDRESSABLE (gnu_subprog_type))
6153               {
6154                 tree gnu_ret_deref
6155                   = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
6156                                     gnu_ret_obj);
6157                 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
6158                                               gnu_ret_deref, gnu_ret_val);
6159                 add_stmt_with_node (gnu_result, gnat_node);
6160                 gnu_ret_val = NULL_TREE;
6161               }
6162           }
6163
6164         else
6165           gnu_ret_obj = gnu_ret_val = NULL_TREE;
6166
6167         /* If we have a return label defined, convert this into a branch to
6168            that label.  The return proper will be handled elsewhere.  */
6169         if (VEC_last (tree, gnu_return_label_stack))
6170           {
6171             if (gnu_ret_obj)
6172               add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
6173                                          gnu_ret_val));
6174
6175             gnu_result = build1 (GOTO_EXPR, void_type_node,
6176                                  VEC_last (tree, gnu_return_label_stack));
6177
6178             /* When not optimizing, make sure the return is preserved.  */
6179             if (!optimize && Comes_From_Source (gnat_node))
6180               DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0;
6181           }
6182
6183         /* Otherwise, build a regular return.  */
6184         else
6185           gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
6186       }
6187       break;
6188
6189     case N_Goto_Statement:
6190       gnu_result
6191         = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node)));
6192       break;
6193
6194     /***************************/
6195     /* Chapter 6: Subprograms  */
6196     /***************************/
6197
6198     case N_Subprogram_Declaration:
6199       /* Unless there is a freeze node, declare the subprogram.  We consider
6200          this a "definition" even though we're not generating code for
6201          the subprogram because we will be making the corresponding GCC
6202          node here.  */
6203
6204       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
6205         gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
6206                             NULL_TREE, 1);
6207       gnu_result = alloc_stmt_list ();
6208       break;
6209
6210     case N_Abstract_Subprogram_Declaration:
6211       /* This subprogram doesn't exist for code generation purposes, but we
6212          have to elaborate the types of any parameters and result, unless
6213          they are imported types (nothing to generate in this case).
6214
6215          The parameter list may contain types with freeze nodes, e.g. not null
6216          subtypes, so the subprogram itself may carry a freeze node, in which
6217          case its elaboration must be deferred.  */
6218
6219       /* Process the parameter types first.  */
6220       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
6221       for (gnat_temp
6222            = First_Formal_With_Extras
6223               (Defining_Entity (Specification (gnat_node)));
6224            Present (gnat_temp);
6225            gnat_temp = Next_Formal_With_Extras (gnat_temp))
6226         if (Is_Itype (Etype (gnat_temp))
6227             && !From_With_Type (Etype (gnat_temp)))
6228           gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
6229
6230       /* Then the result type, set to Standard_Void_Type for procedures.  */
6231       {
6232         Entity_Id gnat_temp_type
6233           = Etype (Defining_Entity (Specification (gnat_node)));
6234
6235         if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
6236           gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
6237       }
6238
6239       gnu_result = alloc_stmt_list ();
6240       break;
6241
6242     case N_Defining_Program_Unit_Name:
6243       /* For a child unit identifier go up a level to get the specification.
6244          We get this when we try to find the spec of a child unit package
6245          that is the compilation unit being compiled.  */
6246       gnu_result = gnat_to_gnu (Parent (gnat_node));
6247       break;
6248
6249     case N_Subprogram_Body:
6250       Subprogram_Body_to_gnu (gnat_node);
6251       gnu_result = alloc_stmt_list ();
6252       break;
6253
6254     case N_Function_Call:
6255     case N_Procedure_Call_Statement:
6256       gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE, false);
6257       break;
6258
6259     /************************/
6260     /* Chapter 7: Packages  */
6261     /************************/
6262
6263     case N_Package_Declaration:
6264       gnu_result = gnat_to_gnu (Specification (gnat_node));
6265       break;
6266
6267     case N_Package_Specification:
6268
6269       start_stmt_group ();
6270       process_decls (Visible_Declarations (gnat_node),
6271                      Private_Declarations (gnat_node), Empty, true, true);
6272       gnu_result = end_stmt_group ();
6273       break;
6274
6275     case N_Package_Body:
6276
6277       /* If this is the body of a generic package - do nothing.  */
6278       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
6279         {
6280           gnu_result = alloc_stmt_list ();
6281           break;
6282         }
6283
6284       start_stmt_group ();
6285       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
6286
6287       if (Present (Handled_Statement_Sequence (gnat_node)))
6288         add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
6289
6290       gnu_result = end_stmt_group ();
6291       break;
6292
6293     /********************************/
6294     /* Chapter 8: Visibility Rules  */
6295     /********************************/
6296
6297     case N_Use_Package_Clause:
6298     case N_Use_Type_Clause:
6299       /* Nothing to do here - but these may appear in list of declarations.  */
6300       gnu_result = alloc_stmt_list ();
6301       break;
6302
6303     /*********************/
6304     /* Chapter 9: Tasks  */
6305     /*********************/
6306
6307     case N_Protected_Type_Declaration:
6308       gnu_result = alloc_stmt_list ();
6309       break;
6310
6311     case N_Single_Task_Declaration:
6312       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
6313       gnu_result = alloc_stmt_list ();
6314       break;
6315
6316     /*********************************************************/
6317     /* Chapter 10: Program Structure and Compilation Issues  */
6318     /*********************************************************/
6319
6320     case N_Compilation_Unit:
6321       /* This is not called for the main unit on which gigi is invoked.  */
6322       Compilation_Unit_to_gnu (gnat_node);
6323       gnu_result = alloc_stmt_list ();
6324       break;
6325
6326     case N_Subprogram_Body_Stub:
6327     case N_Package_Body_Stub:
6328     case N_Protected_Body_Stub:
6329     case N_Task_Body_Stub:
6330       /* Simply process whatever unit is being inserted.  */
6331       gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
6332       break;
6333
6334     case N_Subunit:
6335       gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
6336       break;
6337
6338     /***************************/
6339     /* Chapter 11: Exceptions  */
6340     /***************************/
6341
6342     case N_Handled_Sequence_Of_Statements:
6343       /* If there is an At_End procedure attached to this node, and the EH
6344          mechanism is SJLJ, we must have at least a corresponding At_End
6345          handler, unless the No_Exception_Handlers restriction is set.  */
6346       gcc_assert (type_annotate_only
6347                   || Exception_Mechanism != Setjmp_Longjmp
6348                   || No (At_End_Proc (gnat_node))
6349                   || Present (Exception_Handlers (gnat_node))
6350                   || No_Exception_Handlers_Set ());
6351
6352       gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
6353       break;
6354
6355     case N_Exception_Handler:
6356       if (Exception_Mechanism == Setjmp_Longjmp)
6357         gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
6358       else if (Exception_Mechanism == Back_End_Exceptions)
6359         gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
6360       else
6361         gcc_unreachable ();
6362       break;
6363
6364     case N_Raise_Statement:
6365       /* Only for reraise in back-end exceptions mode.  */
6366       gcc_assert (No (Name (gnat_node))
6367                   && Exception_Mechanism == Back_End_Exceptions);
6368
6369       start_stmt_group ();
6370       gnat_pushlevel ();
6371
6372       /* Clear the current exception pointer so that the occurrence won't be
6373          deallocated.  */
6374       gnu_expr = create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE,
6375                                   ptr_type_node, gnu_incoming_exc_ptr,
6376                                   false, false, false, false, NULL, gnat_node);
6377
6378       add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr,
6379                                  convert (ptr_type_node, integer_zero_node)));
6380       add_stmt (build_call_n_expr (reraise_zcx_decl, 1, gnu_expr));
6381       gnat_poplevel ();
6382       gnu_result = end_stmt_group ();
6383       break;
6384
6385     case N_Push_Constraint_Error_Label:
6386       push_exception_label_stack (&gnu_constraint_error_label_stack,
6387                                   Exception_Label (gnat_node));
6388       break;
6389
6390     case N_Push_Storage_Error_Label:
6391       push_exception_label_stack (&gnu_storage_error_label_stack,
6392                                   Exception_Label (gnat_node));
6393       break;
6394
6395     case N_Push_Program_Error_Label:
6396       push_exception_label_stack (&gnu_program_error_label_stack,
6397                                   Exception_Label (gnat_node));
6398       break;
6399
6400     case N_Pop_Constraint_Error_Label:
6401       VEC_pop (tree, gnu_constraint_error_label_stack);
6402       break;
6403
6404     case N_Pop_Storage_Error_Label:
6405       VEC_pop (tree, gnu_storage_error_label_stack);
6406       break;
6407
6408     case N_Pop_Program_Error_Label:
6409       VEC_pop (tree, gnu_program_error_label_stack);
6410       break;
6411
6412     /******************************/
6413     /* Chapter 12: Generic Units  */
6414     /******************************/
6415
6416     case N_Generic_Function_Renaming_Declaration:
6417     case N_Generic_Package_Renaming_Declaration:
6418     case N_Generic_Procedure_Renaming_Declaration:
6419     case N_Generic_Package_Declaration:
6420     case N_Generic_Subprogram_Declaration:
6421     case N_Package_Instantiation:
6422     case N_Procedure_Instantiation:
6423     case N_Function_Instantiation:
6424       /* These nodes can appear on a declaration list but there is nothing to
6425          to be done with them.  */
6426       gnu_result = alloc_stmt_list ();
6427       break;
6428
6429     /**************************************************/
6430     /* Chapter 13: Representation Clauses and         */
6431     /*             Implementation-Dependent Features  */
6432     /**************************************************/
6433
6434     case N_Attribute_Definition_Clause:
6435       gnu_result = alloc_stmt_list ();
6436
6437       /* The only one we need to deal with is 'Address since, for the others,
6438          the front-end puts the information elsewhere.  */
6439       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
6440         break;
6441
6442       /* And we only deal with 'Address if the object has a Freeze node.  */
6443       gnat_temp = Entity (Name (gnat_node));
6444       if (No (Freeze_Node (gnat_temp)))
6445         break;
6446
6447       /* Get the value to use as the address and save it as the equivalent
6448          for the object.  When it is frozen, gnat_to_gnu_entity will do the
6449          right thing.  */
6450       save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
6451       break;
6452
6453     case N_Enumeration_Representation_Clause:
6454     case N_Record_Representation_Clause:
6455     case N_At_Clause:
6456       /* We do nothing with these.  SEM puts the information elsewhere.  */
6457       gnu_result = alloc_stmt_list ();
6458       break;
6459
6460     case N_Code_Statement:
6461       if (!type_annotate_only)
6462         {
6463           tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
6464           tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
6465           tree gnu_clobbers = NULL_TREE, tail;
6466           bool allows_mem, allows_reg, fake;
6467           int ninputs, noutputs, i;
6468           const char **oconstraints;
6469           const char *constraint;
6470           char *clobber;
6471
6472           /* First retrieve the 3 operand lists built by the front-end.  */
6473           Setup_Asm_Outputs (gnat_node);
6474           while (Present (gnat_temp = Asm_Output_Variable ()))
6475             {
6476               tree gnu_value = gnat_to_gnu (gnat_temp);
6477               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
6478                                                  (Asm_Output_Constraint ()));
6479
6480               gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
6481               Next_Asm_Output ();
6482             }
6483
6484           Setup_Asm_Inputs (gnat_node);
6485           while (Present (gnat_temp = Asm_Input_Value ()))
6486             {
6487               tree gnu_value = gnat_to_gnu (gnat_temp);
6488               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
6489                                                  (Asm_Input_Constraint ()));
6490
6491               gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
6492               Next_Asm_Input ();
6493             }
6494
6495           Clobber_Setup (gnat_node);
6496           while ((clobber = Clobber_Get_Next ()))
6497             gnu_clobbers
6498               = tree_cons (NULL_TREE,
6499                            build_string (strlen (clobber) + 1, clobber),
6500                            gnu_clobbers);
6501
6502           /* Then perform some standard checking and processing on the
6503              operands.  In particular, mark them addressable if needed.  */
6504           gnu_outputs = nreverse (gnu_outputs);
6505           noutputs = list_length (gnu_outputs);
6506           gnu_inputs = nreverse (gnu_inputs);
6507           ninputs = list_length (gnu_inputs);
6508           oconstraints = XALLOCAVEC (const char *, noutputs);
6509
6510           for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
6511             {
6512               tree output = TREE_VALUE (tail);
6513               constraint
6514                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
6515               oconstraints[i] = constraint;
6516
6517               if (parse_output_constraint (&constraint, i, ninputs, noutputs,
6518                                            &allows_mem, &allows_reg, &fake))
6519                 {
6520                   /* If the operand is going to end up in memory,
6521                      mark it addressable.  Note that we don't test
6522                      allows_mem like in the input case below; this
6523                      is modelled on the C front-end.  */
6524                   if (!allows_reg)
6525                     {
6526                       output = remove_conversions (output, false);
6527                       if (TREE_CODE (output) == CONST_DECL
6528                           && DECL_CONST_CORRESPONDING_VAR (output))
6529                         output = DECL_CONST_CORRESPONDING_VAR (output);
6530                       if (!gnat_mark_addressable (output))
6531                         output = error_mark_node;
6532                     }
6533                 }
6534               else
6535                 output = error_mark_node;
6536
6537               TREE_VALUE (tail) = output;
6538             }
6539
6540           for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
6541             {
6542               tree input = TREE_VALUE (tail);
6543               constraint
6544                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
6545
6546               if (parse_input_constraint (&constraint, i, ninputs, noutputs,
6547                                           0, oconstraints,
6548                                           &allows_mem, &allows_reg))
6549                 {
6550                   /* If the operand is going to end up in memory,
6551                      mark it addressable.  */
6552                   if (!allows_reg && allows_mem)
6553                     {
6554                       input = remove_conversions (input, false);
6555                       if (TREE_CODE (input) == CONST_DECL
6556                           && DECL_CONST_CORRESPONDING_VAR (input))
6557                         input = DECL_CONST_CORRESPONDING_VAR (input);
6558                       if (!gnat_mark_addressable (input))
6559                         input = error_mark_node;
6560                     }
6561                 }
6562               else
6563                 input = error_mark_node;
6564
6565               TREE_VALUE (tail) = input;
6566             }
6567
6568           gnu_result = build5 (ASM_EXPR,  void_type_node,
6569                                gnu_template, gnu_outputs,
6570                                gnu_inputs, gnu_clobbers, NULL_TREE);
6571           ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
6572         }
6573       else
6574         gnu_result = alloc_stmt_list ();
6575
6576       break;
6577
6578     /****************/
6579     /* Added Nodes  */
6580     /****************/
6581
6582     case N_Expression_With_Actions:
6583       gnu_result_type = get_unpadded_type (Etype (gnat_node));
6584       /* This construct doesn't define a scope so we don't wrap the statement
6585          list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it
6586          from unsharing.  */
6587       gnu_result = build_stmt_group (Actions (gnat_node), false);
6588       gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
6589       TREE_SIDE_EFFECTS (gnu_result) = 1;
6590       gnu_expr = gnat_to_gnu (Expression (gnat_node));
6591       gnu_result
6592         = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
6593       break;
6594
6595     case N_Freeze_Entity:
6596       start_stmt_group ();
6597       process_freeze_entity (gnat_node);
6598       process_decls (Actions (gnat_node), Empty, Empty, true, true);
6599       gnu_result = end_stmt_group ();
6600       break;
6601
6602     case N_Itype_Reference:
6603       if (!present_gnu_tree (Itype (gnat_node)))
6604         process_type (Itype (gnat_node));
6605
6606       gnu_result = alloc_stmt_list ();
6607       break;
6608
6609     case N_Free_Statement:
6610       if (!type_annotate_only)
6611         {
6612           tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
6613           tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
6614           tree gnu_obj_type;
6615           tree gnu_actual_obj_type = 0;
6616           tree gnu_obj_size;
6617
6618           /* If this is a thin pointer, we must dereference it to create
6619              a fat pointer, then go back below to a thin pointer.  The
6620              reason for this is that we need a fat pointer someplace in
6621              order to properly compute the size.  */
6622           if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
6623             gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
6624                                       build_unary_op (INDIRECT_REF, NULL_TREE,
6625                                                       gnu_ptr));
6626
6627           /* If this is an unconstrained array, we know the object must
6628              have been allocated with the template in front of the object.
6629              So pass the template address, but get the total size.  Do this
6630              by converting to a thin pointer.  */
6631           if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
6632             gnu_ptr
6633               = convert (build_pointer_type
6634                          (TYPE_OBJECT_RECORD_TYPE
6635                           (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
6636                          gnu_ptr);
6637
6638           gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
6639
6640           if (Present (Actual_Designated_Subtype (gnat_node)))
6641             {
6642               gnu_actual_obj_type
6643                 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
6644
6645               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
6646                 gnu_actual_obj_type
6647                   = build_unc_object_type_from_ptr (gnu_ptr_type,
6648                                                     gnu_actual_obj_type,
6649                                                     get_identifier ("DEALLOC"),
6650                                                     false);
6651             }
6652           else
6653             gnu_actual_obj_type = gnu_obj_type;
6654
6655           gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
6656
6657           if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
6658               && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
6659             {
6660               tree gnu_char_ptr_type
6661                 = build_pointer_type (unsigned_char_type_node);
6662               tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
6663               gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
6664               gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
6665                                          gnu_ptr, gnu_pos);
6666             }
6667
6668           gnu_result
6669               = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
6670                                           Procedure_To_Call (gnat_node),
6671                                           Storage_Pool (gnat_node),
6672                                           gnat_node);
6673         }
6674       break;
6675
6676     case N_Raise_Constraint_Error:
6677     case N_Raise_Program_Error:
6678     case N_Raise_Storage_Error:
6679       {
6680         const int reason = UI_To_Int (Reason (gnat_node));
6681         const Node_Id gnat_cond = Condition (gnat_node);
6682         const bool with_extra_info = Exception_Extra_Info
6683                                      && !No_Exception_Handlers_Set ()
6684                                      && !get_exception_label (kind);
6685         tree gnu_cond = NULL_TREE;
6686
6687         if (type_annotate_only)
6688           {
6689             gnu_result = alloc_stmt_list ();
6690             break;
6691           }
6692
6693         gnu_result_type = get_unpadded_type (Etype (gnat_node));
6694
6695         switch (reason)
6696           {
6697           case CE_Access_Check_Failed:
6698             if (with_extra_info)
6699               gnu_result = build_call_raise_column (reason, gnat_node);
6700             break;
6701
6702           case CE_Index_Check_Failed:
6703           case CE_Range_Check_Failed:
6704           case CE_Invalid_Data:
6705             if (Present (gnat_cond)
6706                 && Nkind (gnat_cond) == N_Op_Not
6707                 && Nkind (Right_Opnd (gnat_cond)) == N_In
6708                 && Nkind (Right_Opnd (Right_Opnd (gnat_cond))) == N_Range)
6709               {
6710                 Node_Id gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
6711                 Node_Id gnat_type = Etype (gnat_index);
6712                 Node_Id gnat_range = Right_Opnd (Right_Opnd (gnat_cond));
6713                 tree gnu_index = gnat_to_gnu (gnat_index);
6714                 tree gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range));
6715                 tree gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range));
6716                 struct range_check_info_d *rci;
6717
6718                 if (with_extra_info
6719                     && Known_Esize (gnat_type)
6720                     && UI_To_Int (Esize (gnat_type)) <= 32)
6721                   gnu_result
6722                     = build_call_raise_range (reason, gnat_node, gnu_index,
6723                                               gnu_low_bound, gnu_high_bound);
6724
6725                 /* If loop unswitching is enabled, we try to compute invariant
6726                    conditions for checks applied to iteration variables, i.e.
6727                    conditions that are both independent of the variable and
6728                    necessary in order for the check to fail in the course of
6729                    some iteration, and prepend them to the original condition
6730                    of the checks.  This will make it possible later for the
6731                    loop unswitching pass to replace the loop with two loops,
6732                    one of which has the checks eliminated and the other has
6733                    the original checks reinstated, and a run time selection.
6734                    The former loop will be suitable for vectorization.  */
6735                 if (flag_unswitch_loops
6736                     && (gnu_low_bound = gnat_invariant_expr (gnu_low_bound))
6737                     && (gnu_high_bound = gnat_invariant_expr (gnu_high_bound))
6738                     && (rci = push_range_check_info (gnu_index)))
6739                   {
6740                     rci->low_bound = gnu_low_bound;
6741                     rci->high_bound = gnu_high_bound;
6742                     rci->type = gnat_to_gnu_type (gnat_type);
6743                     rci->invariant_cond = build1 (SAVE_EXPR, boolean_type_node,
6744                                                   boolean_true_node);
6745                     gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
6746                                                 boolean_type_node,
6747                                                 rci->invariant_cond,
6748                                                 gnat_to_gnu (gnat_cond));
6749                   }
6750               }
6751             break;
6752
6753           default:
6754             break;
6755           }
6756
6757         if (gnu_result == error_mark_node)
6758           gnu_result = build_call_raise (reason, gnat_node, kind);
6759
6760         set_expr_location_from_node (gnu_result, gnat_node);
6761
6762         /* If the type is VOID, this is a statement, so we need to generate
6763            the code for the call.  Handle a condition, if there is one.  */
6764         if (VOID_TYPE_P (gnu_result_type))
6765           {
6766             if (Present (gnat_cond))
6767               {
6768                 if (!gnu_cond)
6769                   gnu_cond = gnat_to_gnu (gnat_cond);
6770                 gnu_result
6771                   = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
6772                             alloc_stmt_list ());
6773               }
6774           }
6775         else
6776           gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
6777       }
6778       break;
6779
6780     case N_Validate_Unchecked_Conversion:
6781       {
6782         Entity_Id gnat_target_type = Target_Type (gnat_node);
6783         tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
6784         tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
6785
6786         /* No need for any warning in this case.  */
6787         if (!flag_strict_aliasing)
6788           ;
6789
6790         /* If the result is a pointer type, see if we are either converting
6791            from a non-pointer or from a pointer to a type with a different
6792            alias set and warn if so.  If the result is defined in the same
6793            unit as this unchecked conversion, we can allow this because we
6794            can know to make the pointer type behave properly.  */
6795         else if (POINTER_TYPE_P (gnu_target_type)
6796                  && !In_Same_Source_Unit (gnat_target_type, gnat_node)
6797                  && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
6798           {
6799             tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
6800                                          ? TREE_TYPE (gnu_source_type)
6801                                          : NULL_TREE;
6802             tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
6803
6804             if ((TYPE_IS_DUMMY_P (gnu_target_desig_type)
6805                  || get_alias_set (gnu_target_desig_type) != 0)
6806                 && (!POINTER_TYPE_P (gnu_source_type)
6807                     || (TYPE_IS_DUMMY_P (gnu_source_desig_type)
6808                         != TYPE_IS_DUMMY_P (gnu_target_desig_type))
6809                     || (TYPE_IS_DUMMY_P (gnu_source_desig_type)
6810                         && gnu_source_desig_type != gnu_target_desig_type)
6811                     || !alias_sets_conflict_p
6812                         (get_alias_set (gnu_source_desig_type),
6813                          get_alias_set (gnu_target_desig_type))))
6814               {
6815                 post_error_ne
6816                   ("?possible aliasing problem for type&",
6817                    gnat_node, Target_Type (gnat_node));
6818                 post_error
6819                   ("\\?use -fno-strict-aliasing switch for references",
6820                    gnat_node);
6821                 post_error_ne
6822                   ("\\?or use `pragma No_Strict_Aliasing (&);`",
6823                    gnat_node, Target_Type (gnat_node));
6824               }
6825           }
6826
6827         /* But if the result is a fat pointer type, we have no mechanism to
6828            do that, so we unconditionally warn in problematic cases.  */
6829         else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
6830           {
6831             tree gnu_source_array_type
6832               = TYPE_IS_FAT_POINTER_P (gnu_source_type)
6833                 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
6834                 : NULL_TREE;
6835             tree gnu_target_array_type
6836               = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
6837
6838             if ((TYPE_IS_DUMMY_P (gnu_target_array_type)
6839                  || get_alias_set (gnu_target_array_type) != 0)
6840                 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
6841                     || (TYPE_IS_DUMMY_P (gnu_source_array_type)
6842                         != TYPE_IS_DUMMY_P (gnu_target_array_type))
6843                     || (TYPE_IS_DUMMY_P (gnu_source_array_type)
6844                         && gnu_source_array_type != gnu_target_array_type)
6845                     || !alias_sets_conflict_p
6846                         (get_alias_set (gnu_source_array_type),
6847                          get_alias_set (gnu_target_array_type))))
6848               {
6849                 post_error_ne
6850                   ("?possible aliasing problem for type&",
6851                    gnat_node, Target_Type (gnat_node));
6852                 post_error
6853                   ("\\?use -fno-strict-aliasing switch for references",
6854                    gnat_node);
6855               }
6856           }
6857       }
6858       gnu_result = alloc_stmt_list ();
6859       break;
6860
6861     default:
6862       /* SCIL nodes require no processing for GCC.  Other nodes should only
6863          be present when annotating types.  */
6864       gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only);
6865       gnu_result = alloc_stmt_list ();
6866     }
6867
6868   /* If we pushed the processing of the elaboration routine, pop it back.  */
6869   if (went_into_elab_proc)
6870     current_function_decl = NULL_TREE;
6871
6872   /* When not optimizing, turn boolean rvalues B into B != false tests
6873      so that the code just below can put the location information of the
6874      reference to B on the inequality operator for better debug info.  */
6875   if (!optimize
6876       && TREE_CODE (gnu_result) != INTEGER_CST
6877       && (kind == N_Identifier
6878           || kind == N_Expanded_Name
6879           || kind == N_Explicit_Dereference
6880           || kind == N_Function_Call
6881           || kind == N_Indexed_Component
6882           || kind == N_Selected_Component)
6883       && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
6884       && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
6885     gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
6886                                   convert (gnu_result_type, gnu_result),
6887                                   convert (gnu_result_type,
6888                                            boolean_false_node));
6889
6890   /* Set the location information on the result.  Note that we may have
6891      no result if we tried to build a CALL_EXPR node to a procedure with
6892      no side-effects and optimization is enabled.  */
6893   if (gnu_result && EXPR_P (gnu_result))
6894     set_gnu_expr_location_from_node (gnu_result, gnat_node);
6895
6896   /* If we're supposed to return something of void_type, it means we have
6897      something we're elaborating for effect, so just return.  */
6898   if (TREE_CODE (gnu_result_type) == VOID_TYPE)
6899     return gnu_result;
6900
6901   /* If the result is a constant that overflowed, raise Constraint_Error.  */
6902   if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
6903     {
6904       post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
6905       gnu_result
6906         = build1 (NULL_EXPR, gnu_result_type,
6907                   build_call_raise (CE_Overflow_Check_Failed, gnat_node,
6908                                     N_Raise_Constraint_Error));
6909     }
6910
6911   /* If the result has side-effects and is of an unconstrained type, make a
6912      SAVE_EXPR so that we can be sure it will only be referenced once.  But
6913      this is useless for a call to a function that returns an unconstrained
6914      type with default discriminant, as we cannot compute the size of the
6915      actual returned object.  We must do this before any conversions.  */
6916   if (TREE_SIDE_EFFECTS (gnu_result)
6917       && !(TREE_CODE (gnu_result) == CALL_EXPR
6918            && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
6919       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
6920           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
6921     gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
6922
6923   /* Now convert the result to the result type, unless we are in one of the
6924      following cases:
6925
6926        1. If this is the LHS of an assignment or an actual parameter of a
6927           call, return the result almost unmodified since the RHS will have
6928           to be converted to our type in that case, unless the result type
6929           has a simpler size.  Likewise if there is just a no-op unchecked
6930           conversion in-between.  Similarly, don't convert integral types
6931           that are the operands of an unchecked conversion since we need
6932           to ignore those conversions (for 'Valid).
6933
6934        2. If we have a label (which doesn't have any well-defined type), a
6935           field or an error, return the result almost unmodified.  Similarly,
6936           if the two types are record types with the same name, don't convert.
6937           This will be the case when we are converting from a packable version
6938           of a type to its original type and we need those conversions to be
6939           NOPs in order for assignments into these types to work properly.
6940
6941        3. If the type is void or if we have no result, return error_mark_node
6942           to show we have no result.
6943
6944        4. If this a call to a function that returns an unconstrained type with
6945           default discriminant, return the call expression unmodified since we
6946           cannot compute the size of the actual returned object.
6947
6948        5. Finally, if the type of the result is already correct.  */
6949
6950   if (Present (Parent (gnat_node))
6951       && (lhs_or_actual_p (gnat_node)
6952           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
6953               && unchecked_conversion_nop (Parent (gnat_node)))
6954           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
6955               && !AGGREGATE_TYPE_P (gnu_result_type)
6956               && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
6957       && !(TYPE_SIZE (gnu_result_type)
6958            && TYPE_SIZE (TREE_TYPE (gnu_result))
6959            && (AGGREGATE_TYPE_P (gnu_result_type)
6960                == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
6961            && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
6962                 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
6963                     != INTEGER_CST))
6964                || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
6965                    && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
6966                    && (CONTAINS_PLACEHOLDER_P
6967                        (TYPE_SIZE (TREE_TYPE (gnu_result))))))
6968            && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
6969                 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
6970     {
6971       /* Remove padding only if the inner object is of self-referential
6972          size: in that case it must be an object of unconstrained type
6973          with a default discriminant and we want to avoid copying too
6974          much data.  */
6975       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
6976           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
6977                                      (TREE_TYPE (gnu_result))))))
6978         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
6979                               gnu_result);
6980     }
6981
6982   else if (TREE_CODE (gnu_result) == LABEL_DECL
6983            || TREE_CODE (gnu_result) == FIELD_DECL
6984            || TREE_CODE (gnu_result) == ERROR_MARK
6985            || (TYPE_NAME (gnu_result_type)
6986                == TYPE_NAME (TREE_TYPE (gnu_result))
6987                && TREE_CODE (gnu_result_type) == RECORD_TYPE
6988                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
6989     {
6990       /* Remove any padding.  */
6991       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
6992         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
6993                               gnu_result);
6994     }
6995
6996   else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
6997     gnu_result = error_mark_node;
6998
6999   else if (TREE_CODE (gnu_result) == CALL_EXPR
7000            && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
7001            && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
7002     {
7003       /* ??? We need to convert if the padded type has fixed size because
7004          gnat_types_compatible_p will say that padded types are compatible
7005          but the gimplifier will not and, therefore, will ultimately choke
7006          if there isn't a conversion added early.  */
7007       if (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result))) == INTEGER_CST)
7008         gnu_result = convert (gnu_result_type, gnu_result);
7009     }
7010
7011   else if (TREE_TYPE (gnu_result) != gnu_result_type)
7012     gnu_result = convert (gnu_result_type, gnu_result);
7013
7014   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result.  */
7015   while ((TREE_CODE (gnu_result) == NOP_EXPR
7016           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
7017          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
7018     gnu_result = TREE_OPERAND (gnu_result, 0);
7019
7020   return gnu_result;
7021 }
7022 \f
7023 /* Subroutine of above to push the exception label stack.  GNU_STACK is
7024    a pointer to the stack to update and GNAT_LABEL, if present, is the
7025    label to push onto the stack.  */
7026
7027 static void
7028 push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label)
7029 {
7030   tree gnu_label = (Present (gnat_label)
7031                     ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
7032                     : NULL_TREE);
7033
7034   VEC_safe_push (tree, gc, *gnu_stack, gnu_label);
7035 }
7036 \f
7037 /* Record the current code position in GNAT_NODE.  */
7038
7039 static void
7040 record_code_position (Node_Id gnat_node)
7041 {
7042   tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
7043
7044   add_stmt_with_node (stmt_stmt, gnat_node);
7045   save_gnu_tree (gnat_node, stmt_stmt, true);
7046 }
7047
7048 /* Insert the code for GNAT_NODE at the position saved for that node.  */
7049
7050 static void
7051 insert_code_for (Node_Id gnat_node)
7052 {
7053   STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
7054   save_gnu_tree (gnat_node, NULL_TREE, true);
7055 }
7056 \f
7057 /* Start a new statement group chained to the previous group.  */
7058
7059 void
7060 start_stmt_group (void)
7061 {
7062   struct stmt_group *group = stmt_group_free_list;
7063
7064   /* First see if we can get one from the free list.  */
7065   if (group)
7066     stmt_group_free_list = group->previous;
7067   else
7068     group = ggc_alloc_stmt_group ();
7069
7070   group->previous = current_stmt_group;
7071   group->stmt_list = group->block = group->cleanups = NULL_TREE;
7072   current_stmt_group = group;
7073 }
7074
7075 /* Add GNU_STMT to the current statement group.  If it is an expression with
7076    no effects, it is ignored.  */
7077
7078 void
7079 add_stmt (tree gnu_stmt)
7080 {
7081   append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
7082 }
7083
7084 /* Similar, but the statement is always added, regardless of side-effects.  */
7085
7086 void
7087 add_stmt_force (tree gnu_stmt)
7088 {
7089   append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
7090 }
7091
7092 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE.  */
7093
7094 void
7095 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
7096 {
7097   if (Present (gnat_node))
7098     set_expr_location_from_node (gnu_stmt, gnat_node);
7099   add_stmt (gnu_stmt);
7100 }
7101
7102 /* Similar, but the statement is always added, regardless of side-effects.  */
7103
7104 void
7105 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
7106 {
7107   if (Present (gnat_node))
7108     set_expr_location_from_node (gnu_stmt, gnat_node);
7109   add_stmt_force (gnu_stmt);
7110 }
7111
7112 /* Add a declaration statement for GNU_DECL to the current statement group.
7113    Get SLOC from Entity_Id.  */
7114
7115 void
7116 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
7117 {
7118   tree type = TREE_TYPE (gnu_decl);
7119   tree gnu_stmt, gnu_init, t;
7120
7121   /* If this is a variable that Gigi is to ignore, we may have been given
7122      an ERROR_MARK.  So test for it.  We also might have been given a
7123      reference for a renaming.  So only do something for a decl.  Also
7124      ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE.  */
7125   if (!DECL_P (gnu_decl)
7126       || (TREE_CODE (gnu_decl) == TYPE_DECL
7127           && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
7128     return;
7129
7130   gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
7131
7132   /* If we are global, we don't want to actually output the DECL_EXPR for
7133      this decl since we already have evaluated the expressions in the
7134      sizes and positions as globals and doing it again would be wrong.  */
7135   if (global_bindings_p ())
7136     {
7137       /* Mark everything as used to prevent node sharing with subprograms.
7138          Note that walk_tree knows how to deal with TYPE_DECL, but neither
7139          VAR_DECL nor CONST_DECL.  This appears to be somewhat arbitrary.  */
7140       MARK_VISITED (gnu_stmt);
7141       if (TREE_CODE (gnu_decl) == VAR_DECL
7142           || TREE_CODE (gnu_decl) == CONST_DECL)
7143         {
7144           MARK_VISITED (DECL_SIZE (gnu_decl));
7145           MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
7146           MARK_VISITED (DECL_INITIAL (gnu_decl));
7147         }
7148       /* In any case, we have to deal with our own TYPE_ADA_SIZE field.  */
7149       else if (TREE_CODE (gnu_decl) == TYPE_DECL
7150                && RECORD_OR_UNION_TYPE_P (type)
7151                && !TYPE_FAT_POINTER_P (type))
7152         MARK_VISITED (TYPE_ADA_SIZE (type));
7153     }
7154   else if (!DECL_EXTERNAL (gnu_decl))
7155     add_stmt_with_node (gnu_stmt, gnat_entity);
7156
7157   /* If this is a variable and an initializer is attached to it, it must be
7158      valid for the context.  Similar to init_const in create_var_decl_1.  */
7159   if (TREE_CODE (gnu_decl) == VAR_DECL
7160       && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
7161       && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
7162           || (TREE_STATIC (gnu_decl)
7163               && !initializer_constant_valid_p (gnu_init,
7164                                                 TREE_TYPE (gnu_init)))))
7165     {
7166       /* If GNU_DECL has a padded type, convert it to the unpadded
7167          type so the assignment is done properly.  */
7168       if (TYPE_IS_PADDING_P (type))
7169         t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
7170       else
7171         t = gnu_decl;
7172
7173       gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
7174
7175       DECL_INITIAL (gnu_decl) = NULL_TREE;
7176       if (TREE_READONLY (gnu_decl))
7177         {
7178           TREE_READONLY (gnu_decl) = 0;
7179           DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
7180         }
7181
7182       add_stmt_with_node (gnu_stmt, gnat_entity);
7183     }
7184 }
7185
7186 /* Callback for walk_tree to mark the visited trees rooted at *TP.  */
7187
7188 static tree
7189 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
7190 {
7191   tree t = *tp;
7192
7193   if (TREE_VISITED (t))
7194     *walk_subtrees = 0;
7195
7196   /* Don't mark a dummy type as visited because we want to mark its sizes
7197      and fields once it's filled in.  */
7198   else if (!TYPE_IS_DUMMY_P (t))
7199     TREE_VISITED (t) = 1;
7200
7201   if (TYPE_P (t))
7202     TYPE_SIZES_GIMPLIFIED (t) = 1;
7203
7204   return NULL_TREE;
7205 }
7206
7207 /* Mark nodes rooted at T with TREE_VISITED and types as having their
7208    sized gimplified.  We use this to indicate all variable sizes and
7209    positions in global types may not be shared by any subprogram.  */
7210
7211 void
7212 mark_visited (tree t)
7213 {
7214   walk_tree (&t, mark_visited_r, NULL, NULL);
7215 }
7216
7217 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
7218    set its location to that of GNAT_NODE if present.  */
7219
7220 static void
7221 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
7222 {
7223   if (Present (gnat_node))
7224     set_expr_location_from_node (gnu_cleanup, gnat_node);
7225   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
7226 }
7227
7228 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
7229
7230 void
7231 set_block_for_group (tree gnu_block)
7232 {
7233   gcc_assert (!current_stmt_group->block);
7234   current_stmt_group->block = gnu_block;
7235 }
7236
7237 /* Return code corresponding to the current code group.  It is normally
7238    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
7239    BLOCK or cleanups were set.  */
7240
7241 tree
7242 end_stmt_group (void)
7243 {
7244   struct stmt_group *group = current_stmt_group;
7245   tree gnu_retval = group->stmt_list;
7246
7247   /* If this is a null list, allocate a new STATEMENT_LIST.  Then, if there
7248      are cleanups, make a TRY_FINALLY_EXPR.  Last, if there is a BLOCK,
7249      make a BIND_EXPR.  Note that we nest in that because the cleanup may
7250      reference variables in the block.  */
7251   if (gnu_retval == NULL_TREE)
7252     gnu_retval = alloc_stmt_list ();
7253
7254   if (group->cleanups)
7255     gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
7256                          group->cleanups);
7257
7258   if (current_stmt_group->block)
7259     gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
7260                          gnu_retval, group->block);
7261
7262   /* Remove this group from the stack and add it to the free list.  */
7263   current_stmt_group = group->previous;
7264   group->previous = stmt_group_free_list;
7265   stmt_group_free_list = group;
7266
7267   return gnu_retval;
7268 }
7269
7270 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
7271    statements.*/
7272
7273 static void
7274 add_stmt_list (List_Id gnat_list)
7275 {
7276   Node_Id gnat_node;
7277
7278   if (Present (gnat_list))
7279     for (gnat_node = First (gnat_list); Present (gnat_node);
7280          gnat_node = Next (gnat_node))
7281       add_stmt (gnat_to_gnu (gnat_node));
7282 }
7283
7284 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
7285    If BINDING_P is true, push and pop a binding level around the list.  */
7286
7287 static tree
7288 build_stmt_group (List_Id gnat_list, bool binding_p)
7289 {
7290   start_stmt_group ();
7291   if (binding_p)
7292     gnat_pushlevel ();
7293
7294   add_stmt_list (gnat_list);
7295   if (binding_p)
7296     gnat_poplevel ();
7297
7298   return end_stmt_group ();
7299 }
7300 \f
7301 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
7302
7303 int
7304 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
7305                     gimple_seq *post_p ATTRIBUTE_UNUSED)
7306 {
7307   tree expr = *expr_p;
7308   tree op;
7309
7310   if (IS_ADA_STMT (expr))
7311     return gnat_gimplify_stmt (expr_p);
7312
7313   switch (TREE_CODE (expr))
7314     {
7315     case NULL_EXPR:
7316       /* If this is for a scalar, just make a VAR_DECL for it.  If for
7317          an aggregate, get a null pointer of the appropriate type and
7318          dereference it.  */
7319       if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
7320         *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
7321                           convert (build_pointer_type (TREE_TYPE (expr)),
7322                                    integer_zero_node));
7323       else
7324         {
7325           *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
7326           TREE_NO_WARNING (*expr_p) = 1;
7327         }
7328
7329       gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
7330       return GS_OK;
7331
7332     case UNCONSTRAINED_ARRAY_REF:
7333       /* We should only do this if we are just elaborating for side-effects,
7334          but we can't know that yet.  */
7335       *expr_p = TREE_OPERAND (*expr_p, 0);
7336       return GS_OK;
7337
7338     case ADDR_EXPR:
7339       op = TREE_OPERAND (expr, 0);
7340
7341       /* If we are taking the address of a constant CONSTRUCTOR, make sure it
7342          is put into static memory.  We know that it's going to be read-only
7343          given the semantics we have and it must be in static memory when the
7344          reference is in an elaboration procedure.  */
7345       if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
7346         {
7347           tree addr = build_fold_addr_expr (tree_output_constant_def (op));
7348           *expr_p = fold_convert (TREE_TYPE (expr), addr);
7349           return GS_ALL_DONE;
7350         }
7351
7352       return GS_UNHANDLED;
7353
7354     case VIEW_CONVERT_EXPR:
7355       op = TREE_OPERAND (expr, 0);
7356
7357       /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
7358          type to a scalar one, explicitly create the local temporary.  That's
7359          required if the type is passed by reference.  */
7360       if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
7361           && AGGREGATE_TYPE_P (TREE_TYPE (op))
7362           && !AGGREGATE_TYPE_P (TREE_TYPE (expr)))
7363         {
7364           tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
7365           gimple_add_tmp_var (new_var);
7366
7367           mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
7368           gimplify_and_add (mod, pre_p);
7369
7370           TREE_OPERAND (expr, 0) = new_var;
7371           return GS_OK;
7372         }
7373
7374       return GS_UNHANDLED;
7375
7376     case DECL_EXPR:
7377       op = DECL_EXPR_DECL (expr);
7378
7379       /* The expressions for the RM bounds must be gimplified to ensure that
7380          they are properly elaborated.  See gimplify_decl_expr.  */
7381       if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
7382           && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
7383         switch (TREE_CODE (TREE_TYPE (op)))
7384           {
7385           case INTEGER_TYPE:
7386           case ENUMERAL_TYPE:
7387           case BOOLEAN_TYPE:
7388           case REAL_TYPE:
7389             {
7390               tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
7391
7392               val = TYPE_RM_MIN_VALUE (type);
7393               if (val)
7394                 {
7395                   gimplify_one_sizepos (&val, pre_p);
7396                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
7397                     SET_TYPE_RM_MIN_VALUE (t, val);
7398                 }
7399
7400               val = TYPE_RM_MAX_VALUE (type);
7401               if (val)
7402                 {
7403                   gimplify_one_sizepos (&val, pre_p);
7404                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
7405                     SET_TYPE_RM_MAX_VALUE (t, val);
7406                 }
7407
7408             }
7409             break;
7410
7411           default:
7412             break;
7413           }
7414
7415       /* ... fall through ... */
7416
7417     default:
7418       return GS_UNHANDLED;
7419     }
7420 }
7421
7422 /* Generate GIMPLE in place for the statement at *STMT_P.  */
7423
7424 static enum gimplify_status
7425 gnat_gimplify_stmt (tree *stmt_p)
7426 {
7427   tree stmt = *stmt_p;
7428
7429   switch (TREE_CODE (stmt))
7430     {
7431     case STMT_STMT:
7432       *stmt_p = STMT_STMT_STMT (stmt);
7433       return GS_OK;
7434
7435     case LOOP_STMT:
7436       {
7437         tree gnu_start_label = create_artificial_label (input_location);
7438         tree gnu_cond = LOOP_STMT_COND (stmt);
7439         tree gnu_update = LOOP_STMT_UPDATE (stmt);
7440         tree gnu_end_label = LOOP_STMT_LABEL (stmt);
7441         tree t;
7442
7443         /* Build the condition expression from the test, if any.  */
7444         if (gnu_cond)
7445           gnu_cond
7446             = build3 (COND_EXPR, void_type_node, gnu_cond, alloc_stmt_list (),
7447                       build1 (GOTO_EXPR, void_type_node, gnu_end_label));
7448
7449         /* Set to emit the statements of the loop.  */
7450         *stmt_p = NULL_TREE;
7451
7452         /* We first emit the start label and then a conditional jump to the
7453            end label if there's a top condition, then the update if it's at
7454            the top, then the body of the loop, then a conditional jump to
7455            the end label if there's a bottom condition, then the update if
7456            it's at the bottom, and finally a jump to the start label and the
7457            definition of the end label.  */
7458         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
7459                                           gnu_start_label),
7460                                   stmt_p);
7461
7462         if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
7463           append_to_statement_list (gnu_cond, stmt_p);
7464
7465         if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
7466           append_to_statement_list (gnu_update, stmt_p);
7467
7468         append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
7469
7470         if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
7471           append_to_statement_list (gnu_cond, stmt_p);
7472
7473         if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
7474           append_to_statement_list (gnu_update, stmt_p);
7475
7476         t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
7477         SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
7478         append_to_statement_list (t, stmt_p);
7479
7480         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
7481                                           gnu_end_label),
7482                                   stmt_p);
7483         return GS_OK;
7484       }
7485
7486     case EXIT_STMT:
7487       /* Build a statement to jump to the corresponding end label, then
7488          see if it needs to be conditional.  */
7489       *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
7490       if (EXIT_STMT_COND (stmt))
7491         *stmt_p = build3 (COND_EXPR, void_type_node,
7492                           EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
7493       return GS_OK;
7494
7495     default:
7496       gcc_unreachable ();
7497     }
7498 }
7499 \f
7500 /* Force references to each of the entities in packages withed by GNAT_NODE.
7501    Operate recursively but check that we aren't elaborating something more
7502    than once.
7503
7504    This routine is exclusively called in type_annotate mode, to compute DDA
7505    information for types in withed units, for ASIS use.  */
7506
7507 static void
7508 elaborate_all_entities (Node_Id gnat_node)
7509 {
7510   Entity_Id gnat_with_clause, gnat_entity;
7511
7512   /* Process each unit only once.  As we trace the context of all relevant
7513      units transitively, including generic bodies, we may encounter the
7514      same generic unit repeatedly.  */
7515   if (!present_gnu_tree (gnat_node))
7516      save_gnu_tree (gnat_node, integer_zero_node, true);
7517
7518   /* Save entities in all context units.  A body may have an implicit_with
7519      on its own spec, if the context includes a child unit, so don't save
7520      the spec twice.  */
7521   for (gnat_with_clause = First (Context_Items (gnat_node));
7522        Present (gnat_with_clause);
7523        gnat_with_clause = Next (gnat_with_clause))
7524     if (Nkind (gnat_with_clause) == N_With_Clause
7525         && !present_gnu_tree (Library_Unit (gnat_with_clause))
7526         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
7527       {
7528         elaborate_all_entities (Library_Unit (gnat_with_clause));
7529
7530         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
7531           {
7532             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
7533                  Present (gnat_entity);
7534                  gnat_entity = Next_Entity (gnat_entity))
7535               if (Is_Public (gnat_entity)
7536                   && Convention (gnat_entity) != Convention_Intrinsic
7537                   && Ekind (gnat_entity) != E_Package
7538                   && Ekind (gnat_entity) != E_Package_Body
7539                   && Ekind (gnat_entity) != E_Operator
7540                   && !(IN (Ekind (gnat_entity), Type_Kind)
7541                        && !Is_Frozen (gnat_entity))
7542                   && !((Ekind (gnat_entity) == E_Procedure
7543                         || Ekind (gnat_entity) == E_Function)
7544                        && Is_Intrinsic_Subprogram (gnat_entity))
7545                   && !IN (Ekind (gnat_entity), Named_Kind)
7546                   && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
7547                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
7548           }
7549         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
7550           {
7551             Node_Id gnat_body
7552               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
7553
7554             /* Retrieve compilation unit node of generic body.  */
7555             while (Present (gnat_body)
7556                    && Nkind (gnat_body) != N_Compilation_Unit)
7557               gnat_body = Parent (gnat_body);
7558
7559             /* If body is available, elaborate its context.  */
7560             if (Present (gnat_body))
7561               elaborate_all_entities (gnat_body);
7562           }
7563       }
7564
7565   if (Nkind (Unit (gnat_node)) == N_Package_Body)
7566     elaborate_all_entities (Library_Unit (gnat_node));
7567 }
7568 \f
7569 /* Do the processing of GNAT_NODE, an N_Freeze_Entity.  */
7570
7571 static void
7572 process_freeze_entity (Node_Id gnat_node)
7573 {
7574   const Entity_Id gnat_entity = Entity (gnat_node);
7575   const Entity_Kind kind = Ekind (gnat_entity);
7576   tree gnu_old, gnu_new;
7577
7578   /* If this is a package, we need to generate code for the package.  */
7579   if (kind == E_Package)
7580     {
7581       insert_code_for
7582         (Parent (Corresponding_Body
7583                  (Parent (Declaration_Node (gnat_entity)))));
7584       return;
7585     }
7586
7587   /* Don't do anything for class-wide types as they are always transformed
7588      into their root type.  */
7589   if (kind == E_Class_Wide_Type)
7590     return;
7591
7592   /* Check for an old definition.  This freeze node might be for an Itype.  */
7593   gnu_old
7594     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
7595
7596   /* If this entity has an address representation clause, GNU_OLD is the
7597      address, so discard it here.  */
7598   if (Present (Address_Clause (gnat_entity)))
7599     gnu_old = NULL_TREE;
7600
7601   /* Don't do anything for subprograms that may have been elaborated before
7602      their freeze nodes.  This can happen, for example, because of an inner
7603      call in an instance body or because of previous compilation of a spec
7604      for inlining purposes.  */
7605   if (gnu_old
7606       && ((TREE_CODE (gnu_old) == FUNCTION_DECL
7607            && (kind == E_Function || kind == E_Procedure))
7608           || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
7609               && kind == E_Subprogram_Type)))
7610     return;
7611
7612   /* If we have a non-dummy type old tree, we have nothing to do, except
7613      aborting if this is the public view of a private type whose full view was
7614      not delayed, as this node was never delayed as it should have been.  We
7615      let this happen for concurrent types and their Corresponding_Record_Type,
7616      however, because each might legitimately be elaborated before its own
7617      freeze node, e.g. while processing the other.  */
7618   if (gnu_old
7619       && !(TREE_CODE (gnu_old) == TYPE_DECL
7620            && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
7621     {
7622       gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
7623                    && Present (Full_View (gnat_entity))
7624                    && No (Freeze_Node (Full_View (gnat_entity))))
7625                   || Is_Concurrent_Type (gnat_entity)
7626                   || (IN (kind, Record_Kind)
7627                       && Is_Concurrent_Record_Type (gnat_entity)));
7628       return;
7629     }
7630
7631   /* Reset the saved tree, if any, and elaborate the object or type for real.
7632      If there is a full view, elaborate it and use the result.  And, if this
7633      is the root type of a class-wide type, reuse it for the latter.  */
7634   if (gnu_old)
7635     {
7636       save_gnu_tree (gnat_entity, NULL_TREE, false);
7637       if (IN (kind, Incomplete_Or_Private_Kind)
7638           && Present (Full_View (gnat_entity))
7639           && present_gnu_tree (Full_View (gnat_entity)))
7640         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
7641       if (IN (kind, Type_Kind)
7642           && Present (Class_Wide_Type (gnat_entity))
7643           && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
7644         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
7645     }
7646
7647   if (IN (kind, Incomplete_Or_Private_Kind)
7648       && Present (Full_View (gnat_entity)))
7649     {
7650       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
7651
7652       /* Propagate back-annotations from full view to partial view.  */
7653       if (Unknown_Alignment (gnat_entity))
7654         Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
7655
7656       if (Unknown_Esize (gnat_entity))
7657         Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
7658
7659       if (Unknown_RM_Size (gnat_entity))
7660         Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
7661
7662       /* The above call may have defined this entity (the simplest example
7663          of this is when we have a private enumeral type since the bounds
7664          will have the public view).  */
7665       if (!present_gnu_tree (gnat_entity))
7666         save_gnu_tree (gnat_entity, gnu_new, false);
7667     }
7668   else
7669     {
7670       tree gnu_init
7671         = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
7672            && present_gnu_tree (Declaration_Node (gnat_entity)))
7673           ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
7674
7675       gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
7676     }
7677
7678   if (IN (kind, Type_Kind)
7679       && Present (Class_Wide_Type (gnat_entity))
7680       && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
7681     save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
7682
7683   /* If we have an old type and we've made pointers to this type, update those
7684      pointers.  If this is a Taft amendment type in the main unit, we need to
7685      mark the type as used since other units referencing it don't see the full
7686      declaration and, therefore, cannot mark it as used themselves.  */
7687   if (gnu_old)
7688     {
7689       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
7690                          TREE_TYPE (gnu_new));
7691       if (DECL_TAFT_TYPE_P (gnu_old))
7692         used_types_insert (TREE_TYPE (gnu_new));
7693     }
7694 }
7695 \f
7696 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
7697    We make two passes, one to elaborate anything other than bodies (but
7698    we declare a function if there was no spec).  The second pass
7699    elaborates the bodies.
7700
7701    GNAT_END_LIST gives the element in the list past the end.  Normally,
7702    this is Empty, but can be First_Real_Statement for a
7703    Handled_Sequence_Of_Statements.
7704
7705    We make a complete pass through both lists if PASS1P is true, then make
7706    the second pass over both lists if PASS2P is true.  The lists usually
7707    correspond to the public and private parts of a package.  */
7708
7709 static void
7710 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
7711                Node_Id gnat_end_list, bool pass1p, bool pass2p)
7712 {
7713   List_Id gnat_decl_array[2];
7714   Node_Id gnat_decl;
7715   int i;
7716
7717   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
7718
7719   if (pass1p)
7720     for (i = 0; i <= 1; i++)
7721       if (Present (gnat_decl_array[i]))
7722         for (gnat_decl = First (gnat_decl_array[i]);
7723              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
7724           {
7725             /* For package specs, we recurse inside the declarations,
7726                thus taking the two pass approach inside the boundary.  */
7727             if (Nkind (gnat_decl) == N_Package_Declaration
7728                 && (Nkind (Specification (gnat_decl)
7729                            == N_Package_Specification)))
7730               process_decls (Visible_Declarations (Specification (gnat_decl)),
7731                              Private_Declarations (Specification (gnat_decl)),
7732                              Empty, true, false);
7733
7734             /* Similarly for any declarations in the actions of a
7735                freeze node.  */
7736             else if (Nkind (gnat_decl) == N_Freeze_Entity)
7737               {
7738                 process_freeze_entity (gnat_decl);
7739                 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
7740               }
7741
7742             /* Package bodies with freeze nodes get their elaboration deferred
7743                until the freeze node, but the code must be placed in the right
7744                place, so record the code position now.  */
7745             else if (Nkind (gnat_decl) == N_Package_Body
7746                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
7747               record_code_position (gnat_decl);
7748
7749             else if (Nkind (gnat_decl) == N_Package_Body_Stub
7750                      && Present (Library_Unit (gnat_decl))
7751                      && Present (Freeze_Node
7752                                  (Corresponding_Spec
7753                                   (Proper_Body (Unit
7754                                                 (Library_Unit (gnat_decl)))))))
7755               record_code_position
7756                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
7757
7758             /* We defer most subprogram bodies to the second pass.  */
7759             else if (Nkind (gnat_decl) == N_Subprogram_Body)
7760               {
7761                 if (Acts_As_Spec (gnat_decl))
7762                   {
7763                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
7764
7765                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
7766                         && Ekind (gnat_subprog_id) != E_Generic_Function)
7767                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
7768                   }
7769               }
7770
7771             /* For bodies and stubs that act as their own specs, the entity
7772                itself must be elaborated in the first pass, because it may
7773                be used in other declarations.  */
7774             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
7775               {
7776                 Node_Id gnat_subprog_id
7777                   = Defining_Entity (Specification (gnat_decl));
7778
7779                     if (Ekind (gnat_subprog_id) != E_Subprogram_Body
7780                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
7781                         && Ekind (gnat_subprog_id) != E_Generic_Function)
7782                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
7783               }
7784
7785             /* Concurrent stubs stand for the corresponding subprogram bodies,
7786                which are deferred like other bodies.  */
7787             else if (Nkind (gnat_decl) == N_Task_Body_Stub
7788                      || Nkind (gnat_decl) == N_Protected_Body_Stub)
7789               ;
7790
7791             else
7792               add_stmt (gnat_to_gnu (gnat_decl));
7793           }
7794
7795   /* Here we elaborate everything we deferred above except for package bodies,
7796      which are elaborated at their freeze nodes.  Note that we must also
7797      go inside things (package specs and freeze nodes) the first pass did.  */
7798   if (pass2p)
7799     for (i = 0; i <= 1; i++)
7800       if (Present (gnat_decl_array[i]))
7801         for (gnat_decl = First (gnat_decl_array[i]);
7802              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
7803           {
7804             if (Nkind (gnat_decl) == N_Subprogram_Body
7805                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
7806                 || Nkind (gnat_decl) == N_Task_Body_Stub
7807                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
7808               add_stmt (gnat_to_gnu (gnat_decl));
7809
7810             else if (Nkind (gnat_decl) == N_Package_Declaration
7811                      && (Nkind (Specification (gnat_decl)
7812                                 == N_Package_Specification)))
7813               process_decls (Visible_Declarations (Specification (gnat_decl)),
7814                              Private_Declarations (Specification (gnat_decl)),
7815                              Empty, false, true);
7816
7817             else if (Nkind (gnat_decl) == N_Freeze_Entity)
7818               process_decls (Actions (gnat_decl), Empty, Empty, false, true);
7819           }
7820 }
7821 \f
7822 /* Make a unary operation of kind CODE using build_unary_op, but guard
7823    the operation by an overflow check.  CODE can be one of NEGATE_EXPR
7824    or ABS_EXPR.  GNU_TYPE is the type desired for the result.  Usually
7825    the operation is to be performed in that type.  GNAT_NODE is the gnat
7826    node conveying the source location for which the error should be
7827    signaled.  */
7828
7829 static tree
7830 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
7831                       Node_Id gnat_node)
7832 {
7833   gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
7834
7835   operand = gnat_protect_expr (operand);
7836
7837   return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
7838                                       operand, TYPE_MIN_VALUE (gnu_type)),
7839                      build_unary_op (code, gnu_type, operand),
7840                      CE_Overflow_Check_Failed, gnat_node);
7841 }
7842
7843 /* Make a binary operation of kind CODE using build_binary_op, but guard
7844    the operation by an overflow check.  CODE can be one of PLUS_EXPR,
7845    MINUS_EXPR or MULT_EXPR.  GNU_TYPE is the type desired for the result.
7846    Usually the operation is to be performed in that type.  GNAT_NODE is
7847    the GNAT node conveying the source location for which the error should
7848    be signaled.  */
7849
7850 static tree
7851 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
7852                        tree right, Node_Id gnat_node)
7853 {
7854   tree lhs = gnat_protect_expr (left);
7855   tree rhs = gnat_protect_expr (right);
7856   tree type_max = TYPE_MAX_VALUE (gnu_type);
7857   tree type_min = TYPE_MIN_VALUE (gnu_type);
7858   tree gnu_expr;
7859   tree tmp1, tmp2;
7860   tree zero = convert (gnu_type, integer_zero_node);
7861   tree rhs_lt_zero;
7862   tree check_pos;
7863   tree check_neg;
7864   tree check;
7865   int precision = TYPE_PRECISION (gnu_type);
7866
7867   gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */
7868
7869   /* Prefer a constant or known-positive rhs to simplify checks.  */
7870   if (!TREE_CONSTANT (rhs)
7871       && commutative_tree_code (code)
7872       && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs)
7873                                   && tree_expr_nonnegative_p (lhs))))
7874     {
7875       tree tmp = lhs;
7876       lhs = rhs;
7877       rhs = tmp;
7878     }
7879
7880   rhs_lt_zero = tree_expr_nonnegative_p (rhs)
7881                 ? boolean_false_node
7882                 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
7883
7884   /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
7885
7886   /* Try a few strategies that may be cheaper than the general
7887      code at the end of the function, if the rhs is not known.
7888      The strategies are:
7889        - Call library function for 64-bit multiplication (complex)
7890        - Widen, if input arguments are sufficiently small
7891        - Determine overflow using wrapped result for addition/subtraction.  */
7892
7893   if (!TREE_CONSTANT (rhs))
7894     {
7895       /* Even for add/subtract double size to get another base type.  */
7896       int needed_precision = precision * 2;
7897
7898       if (code == MULT_EXPR && precision == 64)
7899         {
7900           tree int_64 = gnat_type_for_size (64, 0);
7901
7902           return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
7903                                                        convert (int_64, lhs),
7904                                                        convert (int_64, rhs)));
7905         }
7906
7907       else if (needed_precision <= BITS_PER_WORD
7908                || (code == MULT_EXPR
7909                    && needed_precision <= LONG_LONG_TYPE_SIZE))
7910         {
7911           tree wide_type = gnat_type_for_size (needed_precision, 0);
7912
7913           tree wide_result = build_binary_op (code, wide_type,
7914                                               convert (wide_type, lhs),
7915                                               convert (wide_type, rhs));
7916
7917           tree check = build_binary_op
7918             (TRUTH_ORIF_EXPR, boolean_type_node,
7919              build_binary_op (LT_EXPR, boolean_type_node, wide_result,
7920                               convert (wide_type, type_min)),
7921              build_binary_op (GT_EXPR, boolean_type_node, wide_result,
7922                               convert (wide_type, type_max)));
7923
7924           tree result = convert (gnu_type, wide_result);
7925
7926           return
7927             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
7928         }
7929
7930       else if (code == PLUS_EXPR || code == MINUS_EXPR)
7931         {
7932           tree unsigned_type = gnat_type_for_size (precision, 1);
7933           tree wrapped_expr = convert
7934             (gnu_type, build_binary_op (code, unsigned_type,
7935                                         convert (unsigned_type, lhs),
7936                                         convert (unsigned_type, rhs)));
7937
7938           tree result = convert
7939             (gnu_type, build_binary_op (code, gnu_type, lhs, rhs));
7940
7941           /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
7942              or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction.  */
7943           tree check = build_binary_op
7944             (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
7945              build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
7946                               boolean_type_node, wrapped_expr, lhs));
7947
7948           return
7949             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
7950         }
7951    }
7952
7953   switch (code)
7954     {
7955     case PLUS_EXPR:
7956       /* When rhs >= 0, overflow when lhs > type_max - rhs.  */
7957       check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
7958                                    build_binary_op (MINUS_EXPR, gnu_type,
7959                                                     type_max, rhs)),
7960
7961       /* When rhs < 0, overflow when lhs < type_min - rhs.  */
7962       check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
7963                                    build_binary_op (MINUS_EXPR, gnu_type,
7964                                                     type_min, rhs));
7965       break;
7966
7967     case MINUS_EXPR:
7968       /* When rhs >= 0, overflow when lhs < type_min + rhs.  */
7969       check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
7970                                    build_binary_op (PLUS_EXPR, gnu_type,
7971                                                     type_min, rhs)),
7972
7973       /* When rhs < 0, overflow when lhs > type_max + rhs.  */
7974       check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
7975                                    build_binary_op (PLUS_EXPR, gnu_type,
7976                                                     type_max, rhs));
7977       break;
7978
7979     case MULT_EXPR:
7980       /* The check here is designed to be efficient if the rhs is constant,
7981          but it will work for any rhs by using integer division.
7982          Four different check expressions determine whether X * C overflows,
7983          depending on C.
7984            C ==  0  =>  false
7985            C  >  0  =>  X > type_max / C || X < type_min / C
7986            C == -1  =>  X == type_min
7987            C  < -1  =>  X > type_min / C || X < type_max / C */
7988
7989       tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
7990       tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
7991
7992       check_pos
7993         = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
7994                            build_binary_op (NE_EXPR, boolean_type_node, zero,
7995                                             rhs),
7996                            build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7997                                             build_binary_op (GT_EXPR,
7998                                                              boolean_type_node,
7999                                                              lhs, tmp1),
8000                                             build_binary_op (LT_EXPR,
8001                                                              boolean_type_node,
8002                                                              lhs, tmp2)));
8003
8004       check_neg
8005         = fold_build3 (COND_EXPR, boolean_type_node,
8006                        build_binary_op (EQ_EXPR, boolean_type_node, rhs,
8007                                         build_int_cst (gnu_type, -1)),
8008                        build_binary_op (EQ_EXPR, boolean_type_node, lhs,
8009                                         type_min),
8010                        build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8011                                         build_binary_op (GT_EXPR,
8012                                                          boolean_type_node,
8013                                                          lhs, tmp2),
8014                                         build_binary_op (LT_EXPR,
8015                                                          boolean_type_node,
8016                                                          lhs, tmp1)));
8017       break;
8018
8019     default:
8020       gcc_unreachable();
8021     }
8022
8023   gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
8024
8025   /* If we can fold the expression to a constant, just return it.
8026      The caller will deal with overflow, no need to generate a check.  */
8027   if (TREE_CONSTANT (gnu_expr))
8028     return gnu_expr;
8029
8030   check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
8031                        check_pos);
8032
8033   return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
8034 }
8035
8036 /* Emit code for a range check.  GNU_EXPR is the expression to be checked,
8037    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
8038    which we have to check.  GNAT_NODE is the GNAT node conveying the source
8039    location for which the error should be signaled.  */
8040
8041 static tree
8042 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
8043 {
8044   tree gnu_range_type = get_unpadded_type (gnat_range_type);
8045   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
8046   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
8047   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
8048
8049   /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
8050      This can for example happen when translating 'Val or 'Value.  */
8051   if (gnu_compare_type == gnu_range_type)
8052     return gnu_expr;
8053
8054   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
8055      we can't do anything since we might be truncating the bounds.  No
8056      check is needed in this case.  */
8057   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
8058       && (TYPE_PRECISION (gnu_compare_type)
8059           < TYPE_PRECISION (get_base_type (gnu_range_type))))
8060     return gnu_expr;
8061
8062   /* Checked expressions must be evaluated only once.  */
8063   gnu_expr = gnat_protect_expr (gnu_expr);
8064
8065   /* Note that the form of the check is
8066         (not (expr >= lo)) or (not (expr <= hi))
8067      the reason for this slightly convoluted form is that NaNs
8068      are not considered to be in range in the float case.  */
8069   return emit_check
8070     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8071                       invert_truthvalue
8072                       (build_binary_op (GE_EXPR, boolean_type_node,
8073                                        convert (gnu_compare_type, gnu_expr),
8074                                        convert (gnu_compare_type, gnu_low))),
8075                       invert_truthvalue
8076                       (build_binary_op (LE_EXPR, boolean_type_node,
8077                                         convert (gnu_compare_type, gnu_expr),
8078                                         convert (gnu_compare_type,
8079                                                  gnu_high)))),
8080      gnu_expr, CE_Range_Check_Failed, gnat_node);
8081 }
8082 \f
8083 /* Emit code for an index check.  GNU_ARRAY_OBJECT is the array object which
8084    we are about to index, GNU_EXPR is the index expression to be checked,
8085    GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
8086    has to be checked.  Note that for index checking we cannot simply use the
8087    emit_range_check function (although very similar code needs to be generated
8088    in both cases) since for index checking the array type against which we are
8089    checking the indices may be unconstrained and consequently we need to get
8090    the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
8091    The place where we need to do that is in subprograms having unconstrained
8092    array formal parameters.  GNAT_NODE is the GNAT node conveying the source
8093    location for which the error should be signaled.  */
8094
8095 static tree
8096 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
8097                   tree gnu_high, Node_Id gnat_node)
8098 {
8099   tree gnu_expr_check;
8100
8101   /* Checked expressions must be evaluated only once.  */
8102   gnu_expr = gnat_protect_expr (gnu_expr);
8103
8104   /* Must do this computation in the base type in case the expression's
8105      type is an unsigned subtypes.  */
8106   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
8107
8108   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
8109      the object we are handling.  */
8110   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
8111   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
8112
8113   return emit_check
8114     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8115                       build_binary_op (LT_EXPR, boolean_type_node,
8116                                        gnu_expr_check,
8117                                        convert (TREE_TYPE (gnu_expr_check),
8118                                                 gnu_low)),
8119                       build_binary_op (GT_EXPR, boolean_type_node,
8120                                        gnu_expr_check,
8121                                        convert (TREE_TYPE (gnu_expr_check),
8122                                                 gnu_high))),
8123      gnu_expr, CE_Index_Check_Failed, gnat_node);
8124 }
8125 \f
8126 /* GNU_COND contains the condition corresponding to an access, discriminant or
8127    range check of value GNU_EXPR.  Build a COND_EXPR that returns GNU_EXPR if
8128    GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
8129    REASON is the code that says why the exception was raised.  GNAT_NODE is
8130    the GNAT node conveying the source location for which the error should be
8131    signaled.  */
8132
8133 static tree
8134 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
8135 {
8136   tree gnu_call
8137     = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
8138   tree gnu_result
8139     = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
8140                    build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
8141                            convert (TREE_TYPE (gnu_expr), integer_zero_node)),
8142                    gnu_expr);
8143
8144   /* GNU_RESULT has side effects if and only if GNU_EXPR has:
8145      we don't need to evaluate it just for the check.  */
8146   TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
8147
8148   return gnu_result;
8149 }
8150 \f
8151 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
8152    checks if OVERFLOW_P is true and range checks if RANGE_P is true.
8153    GNAT_TYPE is known to be an integral type.  If TRUNCATE_P true, do a
8154    float to integer conversion with truncation; otherwise round.
8155    GNAT_NODE is the GNAT node conveying the source location for which the
8156    error should be signaled.  */
8157
8158 static tree
8159 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
8160                     bool rangep, bool truncatep, Node_Id gnat_node)
8161 {
8162   tree gnu_type = get_unpadded_type (gnat_type);
8163   tree gnu_in_type = TREE_TYPE (gnu_expr);
8164   tree gnu_in_basetype = get_base_type (gnu_in_type);
8165   tree gnu_base_type = get_base_type (gnu_type);
8166   tree gnu_result = gnu_expr;
8167
8168   /* If we are not doing any checks, the output is an integral type, and
8169      the input is not a floating type, just do the conversion.  This
8170      shortcut is required to avoid problems with packed array types
8171      and simplifies code in all cases anyway.   */
8172   if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
8173       && !FLOAT_TYPE_P (gnu_in_type))
8174     return convert (gnu_type, gnu_expr);
8175
8176   /* First convert the expression to its base type.  This
8177      will never generate code, but makes the tests below much simpler.
8178      But don't do this if converting from an integer type to an unconstrained
8179      array type since then we need to get the bounds from the original
8180      (unpacked) type.  */
8181   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
8182     gnu_result = convert (gnu_in_basetype, gnu_result);
8183
8184   /* If overflow checks are requested,  we need to be sure the result will
8185      fit in the output base type.  But don't do this if the input
8186      is integer and the output floating-point.  */
8187   if (overflowp
8188       && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
8189     {
8190       /* Ensure GNU_EXPR only gets evaluated once.  */
8191       tree gnu_input = gnat_protect_expr (gnu_result);
8192       tree gnu_cond = boolean_false_node;
8193       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
8194       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
8195       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
8196       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
8197
8198       /* Convert the lower bounds to signed types, so we're sure we're
8199          comparing them properly.  Likewise, convert the upper bounds
8200          to unsigned types.  */
8201       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
8202         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
8203
8204       if (INTEGRAL_TYPE_P (gnu_in_basetype)
8205           && !TYPE_UNSIGNED (gnu_in_basetype))
8206         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
8207
8208       if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
8209         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
8210
8211       if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
8212         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
8213
8214       /* Check each bound separately and only if the result bound
8215          is tighter than the bound on the input type.  Note that all the
8216          types are base types, so the bounds must be constant. Also,
8217          the comparison is done in the base type of the input, which
8218          always has the proper signedness.  First check for input
8219          integer (which means output integer), output float (which means
8220          both float), or mixed, in which case we always compare.
8221          Note that we have to do the comparison which would *fail* in the
8222          case of an error since if it's an FP comparison and one of the
8223          values is a NaN or Inf, the comparison will fail.  */
8224       if (INTEGRAL_TYPE_P (gnu_in_basetype)
8225           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
8226           : (FLOAT_TYPE_P (gnu_base_type)
8227              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
8228                                  TREE_REAL_CST (gnu_out_lb))
8229              : 1))
8230         gnu_cond
8231           = invert_truthvalue
8232             (build_binary_op (GE_EXPR, boolean_type_node,
8233                               gnu_input, convert (gnu_in_basetype,
8234                                                   gnu_out_lb)));
8235
8236       if (INTEGRAL_TYPE_P (gnu_in_basetype)
8237           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
8238           : (FLOAT_TYPE_P (gnu_base_type)
8239              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
8240                                  TREE_REAL_CST (gnu_in_lb))
8241              : 1))
8242         gnu_cond
8243           = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
8244                              invert_truthvalue
8245                              (build_binary_op (LE_EXPR, boolean_type_node,
8246                                                gnu_input,
8247                                                convert (gnu_in_basetype,
8248                                                         gnu_out_ub))));
8249
8250       if (!integer_zerop (gnu_cond))
8251         gnu_result = emit_check (gnu_cond, gnu_input,
8252                                  CE_Overflow_Check_Failed, gnat_node);
8253     }
8254
8255   /* Now convert to the result base type.  If this is a non-truncating
8256      float-to-integer conversion, round.  */
8257   if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
8258       && !truncatep)
8259     {
8260       REAL_VALUE_TYPE half_minus_pred_half, pred_half;
8261       tree gnu_conv, gnu_zero, gnu_comp, calc_type;
8262       tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
8263       const struct real_format *fmt;
8264
8265       /* The following calculations depend on proper rounding to even
8266          of each arithmetic operation. In order to prevent excess
8267          precision from spoiling this property, use the widest hardware
8268          floating-point type if FP_ARITH_MAY_WIDEN is true.  */
8269       calc_type
8270         = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
8271
8272       /* FIXME: Should not have padding in the first place.  */
8273       if (TYPE_IS_PADDING_P (calc_type))
8274         calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
8275
8276       /* Compute the exact value calc_type'Pred (0.5) at compile time.  */
8277       fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
8278       real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
8279       REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
8280                        half_minus_pred_half);
8281       gnu_pred_half = build_real (calc_type, pred_half);
8282
8283       /* If the input is strictly negative, subtract this value
8284          and otherwise add it from the input.  For 0.5, the result
8285          is exactly between 1.0 and the machine number preceding 1.0
8286          (for calc_type).  Since the last bit of 1.0 is even, this 0.5
8287          will round to 1.0, while all other number with an absolute
8288          value less than 0.5 round to 0.0.  For larger numbers exactly
8289          halfway between integers, rounding will always be correct as
8290          the true mathematical result will be closer to the higher
8291          integer compared to the lower one.  So, this constant works
8292          for all floating-point numbers.
8293
8294          The reason to use the same constant with subtract/add instead
8295          of a positive and negative constant is to allow the comparison
8296          to be scheduled in parallel with retrieval of the constant and
8297          conversion of the input to the calc_type (if necessary).  */
8298
8299       gnu_zero = convert (gnu_in_basetype, integer_zero_node);
8300       gnu_result = gnat_protect_expr (gnu_result);
8301       gnu_conv = convert (calc_type, gnu_result);
8302       gnu_comp
8303         = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
8304       gnu_add_pred_half
8305         = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
8306       gnu_subtract_pred_half
8307         = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
8308       gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
8309                                 gnu_add_pred_half, gnu_subtract_pred_half);
8310     }
8311
8312   if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
8313       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
8314       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
8315     gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
8316   else
8317     gnu_result = convert (gnu_base_type, gnu_result);
8318
8319   /* Finally, do the range check if requested.  Note that if the result type
8320      is a modular type, the range check is actually an overflow check.  */
8321   if (rangep
8322       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
8323           && TYPE_MODULAR_P (gnu_base_type) && overflowp))
8324     gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
8325
8326   return convert (gnu_type, gnu_result);
8327 }
8328 \f
8329 /* Return true if GNU_EXPR can be directly addressed.  This is the case
8330    unless it is an expression involving computation or if it involves a
8331    reference to a bitfield or to an object not sufficiently aligned for
8332    its type.  If GNU_TYPE is non-null, return true only if GNU_EXPR can
8333    be directly addressed as an object of this type.
8334
8335    *** Notes on addressability issues in the Ada compiler ***
8336
8337    This predicate is necessary in order to bridge the gap between Gigi
8338    and the middle-end about addressability of GENERIC trees.  A tree
8339    is said to be addressable if it can be directly addressed, i.e. if
8340    its address can be taken, is a multiple of the type's alignment on
8341    strict-alignment architectures and returns the first storage unit
8342    assigned to the object represented by the tree.
8343
8344    In the C family of languages, everything is in practice addressable
8345    at the language level, except for bit-fields.  This means that these
8346    compilers will take the address of any tree that doesn't represent
8347    a bit-field reference and expect the result to be the first storage
8348    unit assigned to the object.  Even in cases where this will result
8349    in unaligned accesses at run time, nothing is supposed to be done
8350    and the program is considered as erroneous instead (see PR c/18287).
8351
8352    The implicit assumptions made in the middle-end are in keeping with
8353    the C viewpoint described above:
8354      - the address of a bit-field reference is supposed to be never
8355        taken; the compiler (generally) will stop on such a construct,
8356      - any other tree is addressable if it is formally addressable,
8357        i.e. if it is formally allowed to be the operand of ADDR_EXPR.
8358
8359    In Ada, the viewpoint is the opposite one: nothing is addressable
8360    at the language level unless explicitly declared so.  This means
8361    that the compiler will both make sure that the trees representing
8362    references to addressable ("aliased" in Ada parlance) objects are
8363    addressable and make no real attempts at ensuring that the trees
8364    representing references to non-addressable objects are addressable.
8365
8366    In the first case, Ada is effectively equivalent to C and handing
8367    down the direct result of applying ADDR_EXPR to these trees to the
8368    middle-end works flawlessly.  In the second case, Ada cannot afford
8369    to consider the program as erroneous if the address of trees that
8370    are not addressable is requested for technical reasons, unlike C;
8371    as a consequence, the Ada compiler must arrange for either making
8372    sure that this address is not requested in the middle-end or for
8373    compensating by inserting temporaries if it is requested in Gigi.
8374
8375    The first goal can be achieved because the middle-end should not
8376    request the address of non-addressable trees on its own; the only
8377    exception is for the invocation of low-level block operations like
8378    memcpy, for which the addressability requirements are lower since
8379    the type's alignment can be disregarded.  In practice, this means
8380    that Gigi must make sure that such operations cannot be applied to
8381    non-BLKmode bit-fields.
8382
8383    The second goal is achieved by means of the addressable_p predicate,
8384    which computes whether a temporary must be inserted by Gigi when the
8385    address of a tree is requested; if so, the address of the temporary
8386    will be used in lieu of that of the original tree and some glue code
8387    generated to connect everything together.  */
8388
8389 static bool
8390 addressable_p (tree gnu_expr, tree gnu_type)
8391 {
8392   /* For an integral type, the size of the actual type of the object may not
8393      be greater than that of the expected type, otherwise an indirect access
8394      in the latter type wouldn't correctly set all the bits of the object.  */
8395   if (gnu_type
8396       && INTEGRAL_TYPE_P (gnu_type)
8397       && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
8398     return false;
8399
8400   /* The size of the actual type of the object may not be smaller than that
8401      of the expected type, otherwise an indirect access in the latter type
8402      would be larger than the object.  But only record types need to be
8403      considered in practice for this case.  */
8404   if (gnu_type
8405       && TREE_CODE (gnu_type) == RECORD_TYPE
8406       && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
8407     return false;
8408
8409   switch (TREE_CODE (gnu_expr))
8410     {
8411     case VAR_DECL:
8412     case PARM_DECL:
8413     case FUNCTION_DECL:
8414     case RESULT_DECL:
8415       /* All DECLs are addressable: if they are in a register, we can force
8416          them to memory.  */
8417       return true;
8418
8419     case UNCONSTRAINED_ARRAY_REF:
8420     case INDIRECT_REF:
8421       /* Taking the address of a dereference yields the original pointer.  */
8422       return true;
8423
8424     case STRING_CST:
8425     case INTEGER_CST:
8426       /* Taking the address yields a pointer to the constant pool.  */
8427       return true;
8428
8429     case CONSTRUCTOR:
8430       /* Taking the address of a static constructor yields a pointer to the
8431          tree constant pool.  */
8432       return TREE_STATIC (gnu_expr) ? true : false;
8433
8434     case NULL_EXPR:
8435     case SAVE_EXPR:
8436     case CALL_EXPR:
8437     case PLUS_EXPR:
8438     case MINUS_EXPR:
8439     case BIT_IOR_EXPR:
8440     case BIT_XOR_EXPR:
8441     case BIT_AND_EXPR:
8442     case BIT_NOT_EXPR:
8443       /* All rvalues are deemed addressable since taking their address will
8444          force a temporary to be created by the middle-end.  */
8445       return true;
8446
8447     case COMPOUND_EXPR:
8448       /* The address of a compound expression is that of its 2nd operand.  */
8449       return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
8450
8451     case COND_EXPR:
8452       /* We accept &COND_EXPR as soon as both operands are addressable and
8453          expect the outcome to be the address of the selected operand.  */
8454       return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
8455               && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
8456
8457     case COMPONENT_REF:
8458       return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
8459                 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
8460                    the field is sufficiently aligned, in case it is subject
8461                    to a pragma Component_Alignment.  But we don't need to
8462                    check the alignment of the containing record, as it is
8463                    guaranteed to be not smaller than that of its most
8464                    aligned field that is not a bit-field.  */
8465                 && (!STRICT_ALIGNMENT
8466                     || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
8467                        >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
8468                /* The field of a padding record is always addressable.  */
8469                || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
8470               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
8471
8472     case ARRAY_REF:  case ARRAY_RANGE_REF:
8473     case REALPART_EXPR:  case IMAGPART_EXPR:
8474     case NOP_EXPR:
8475       return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
8476
8477     case CONVERT_EXPR:
8478       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
8479               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
8480
8481     case VIEW_CONVERT_EXPR:
8482       {
8483         /* This is addressable if we can avoid a copy.  */
8484         tree type = TREE_TYPE (gnu_expr);
8485         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
8486         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
8487                   && (!STRICT_ALIGNMENT
8488                       || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
8489                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
8490                  || ((TYPE_MODE (type) == BLKmode
8491                       || TYPE_MODE (inner_type) == BLKmode)
8492                      && (!STRICT_ALIGNMENT
8493                          || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
8494                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
8495                          || TYPE_ALIGN_OK (type)
8496                          || TYPE_ALIGN_OK (inner_type))))
8497                 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
8498       }
8499
8500     default:
8501       return false;
8502     }
8503 }
8504 \f
8505 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
8506    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
8507    make a GCC type for GNAT_ENTITY and set up the correspondence.  */
8508
8509 void
8510 process_type (Entity_Id gnat_entity)
8511 {
8512   tree gnu_old
8513     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
8514   tree gnu_new;
8515
8516   /* If we are to delay elaboration of this type, just do any
8517      elaborations needed for expressions within the declaration and
8518      make a dummy type entry for this node and its Full_View (if
8519      any) in case something points to it.  Don't do this if it
8520      has already been done (the only way that can happen is if
8521      the private completion is also delayed).  */
8522   if (Present (Freeze_Node (gnat_entity))
8523       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
8524           && Present (Full_View (gnat_entity))
8525           && Freeze_Node (Full_View (gnat_entity))
8526           && !present_gnu_tree (Full_View (gnat_entity))))
8527     {
8528       elaborate_entity (gnat_entity);
8529
8530       if (!gnu_old)
8531         {
8532           tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
8533           save_gnu_tree (gnat_entity, gnu_decl, false);
8534           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
8535               && Present (Full_View (gnat_entity)))
8536             {
8537               if (Has_Completion_In_Body (gnat_entity))
8538                 DECL_TAFT_TYPE_P (gnu_decl) = 1;
8539               save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
8540             }
8541         }
8542
8543       return;
8544     }
8545
8546   /* If we saved away a dummy type for this node it means that this
8547      made the type that corresponds to the full type of an incomplete
8548      type.  Clear that type for now and then update the type in the
8549      pointers.  */
8550   if (gnu_old)
8551     {
8552       gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
8553                   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
8554
8555       save_gnu_tree (gnat_entity, NULL_TREE, false);
8556     }
8557
8558   /* Now fully elaborate the type.  */
8559   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
8560   gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
8561
8562   /* If we have an old type and we've made pointers to this type, update those
8563      pointers.  If this is a Taft amendment type in the main unit, we need to
8564      mark the type as used since other units referencing it don't see the full
8565      declaration and, therefore, cannot mark it as used themselves.  */
8566   if (gnu_old)
8567     {
8568       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
8569                          TREE_TYPE (gnu_new));
8570       if (DECL_TAFT_TYPE_P (gnu_old))
8571         used_types_insert (TREE_TYPE (gnu_new));
8572     }
8573
8574   /* If this is a record type corresponding to a task or protected type
8575      that is a completion of an incomplete type, perform a similar update
8576      on the type.  ??? Including protected types here is a guess.  */
8577   if (IN (Ekind (gnat_entity), Record_Kind)
8578       && Is_Concurrent_Record_Type (gnat_entity)
8579       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
8580     {
8581       tree gnu_task_old
8582         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
8583
8584       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
8585                      NULL_TREE, false);
8586       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
8587                      gnu_new, false);
8588
8589       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
8590                          TREE_TYPE (gnu_new));
8591     }
8592 }
8593 \f
8594 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
8595    front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
8596    GCC type of the corresponding record type.  Return the CONSTRUCTOR.  */
8597
8598 static tree
8599 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
8600 {
8601   tree gnu_list = NULL_TREE, gnu_result;
8602
8603   /* We test for GNU_FIELD being empty in the case where a variant
8604      was the last thing since we don't take things off GNAT_ASSOC in
8605      that case.  We check GNAT_ASSOC in case we have a variant, but it
8606      has no fields.  */
8607
8608   for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
8609     {
8610       Node_Id gnat_field = First (Choices (gnat_assoc));
8611       tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
8612       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
8613
8614       /* The expander is supposed to put a single component selector name
8615          in every record component association.  */
8616       gcc_assert (No (Next (gnat_field)));
8617
8618       /* Ignore fields that have Corresponding_Discriminants since we'll
8619          be setting that field in the parent.  */
8620       if (Present (Corresponding_Discriminant (Entity (gnat_field)))
8621           && Is_Tagged_Type (Scope (Entity (gnat_field))))
8622         continue;
8623
8624       /* Also ignore discriminants of Unchecked_Unions.  */
8625       if (Is_Unchecked_Union (gnat_entity)
8626           && Ekind (Entity (gnat_field)) == E_Discriminant)
8627         continue;
8628
8629       /* Before assigning a value in an aggregate make sure range checks
8630          are done if required.  Then convert to the type of the field.  */
8631       if (Do_Range_Check (Expression (gnat_assoc)))
8632         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
8633
8634       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
8635
8636       /* Add the field and expression to the list.  */
8637       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
8638     }
8639
8640   gnu_result = extract_values (gnu_list, gnu_type);
8641
8642 #ifdef ENABLE_CHECKING
8643   /* Verify that every entry in GNU_LIST was used.  */
8644   for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
8645     gcc_assert (TREE_ADDRESSABLE (gnu_list));
8646 #endif
8647
8648   return gnu_result;
8649 }
8650
8651 /* Build a possibly nested constructor for array aggregates.  GNAT_EXPR is
8652    the first element of an array aggregate.  It may itself be an aggregate.
8653    GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
8654    GNAT_COMPONENT_TYPE is the type of the array component; it is needed
8655    for range checking.  */
8656
8657 static tree
8658 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
8659                     Entity_Id gnat_component_type)
8660 {
8661   tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
8662   tree gnu_expr;
8663   VEC(constructor_elt,gc) *gnu_expr_vec = NULL;
8664
8665   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
8666     {
8667       /* If the expression is itself an array aggregate then first build the
8668          innermost constructor if it is part of our array (multi-dimensional
8669          case).  */
8670       if (Nkind (gnat_expr) == N_Aggregate
8671           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
8672           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
8673         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
8674                                        TREE_TYPE (gnu_array_type),
8675                                        gnat_component_type);
8676       else
8677         {
8678           gnu_expr = gnat_to_gnu (gnat_expr);
8679
8680           /* Before assigning the element to the array, make sure it is
8681              in range.  */
8682           if (Do_Range_Check (gnat_expr))
8683             gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
8684         }
8685
8686       CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
8687                               convert (TREE_TYPE (gnu_array_type), gnu_expr));
8688
8689       gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node);
8690     }
8691
8692   return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
8693 }
8694 \f
8695 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
8696    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
8697    of the associations that are from RECORD_TYPE.  If we see an internal
8698    record, make a recursive call to fill it in as well.  */
8699
8700 static tree
8701 extract_values (tree values, tree record_type)
8702 {
8703   tree field, tem;
8704   VEC(constructor_elt,gc) *v = NULL;
8705
8706   for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
8707     {
8708       tree value = 0;
8709
8710       /* _Parent is an internal field, but may have values in the aggregate,
8711          so check for values first.  */
8712       if ((tem = purpose_member (field, values)))
8713         {
8714           value = TREE_VALUE (tem);
8715           TREE_ADDRESSABLE (tem) = 1;
8716         }
8717
8718       else if (DECL_INTERNAL_P (field))
8719         {
8720           value = extract_values (values, TREE_TYPE (field));
8721           if (TREE_CODE (value) == CONSTRUCTOR
8722               && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
8723             value = 0;
8724         }
8725       else
8726         /* If we have a record subtype, the names will match, but not the
8727            actual FIELD_DECLs.  */
8728         for (tem = values; tem; tem = TREE_CHAIN (tem))
8729           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
8730             {
8731               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
8732               TREE_ADDRESSABLE (tem) = 1;
8733             }
8734
8735       if (!value)
8736         continue;
8737
8738       CONSTRUCTOR_APPEND_ELT (v, field, value);
8739     }
8740
8741   return gnat_build_constructor (record_type, v);
8742 }
8743 \f
8744 /* EXP is to be treated as an array or record.  Handle the cases when it is
8745    an access object and perform the required dereferences.  */
8746
8747 static tree
8748 maybe_implicit_deref (tree exp)
8749 {
8750   /* If the type is a pointer, dereference it.  */
8751   if (POINTER_TYPE_P (TREE_TYPE (exp))
8752       || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
8753     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
8754
8755   /* If we got a padded type, remove it too.  */
8756   if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
8757     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
8758
8759   return exp;
8760 }
8761 \f
8762 /* Convert SLOC into LOCUS.  Return true if SLOC corresponds to a source code
8763    location and false if it doesn't.  In the former case, set the Gigi global
8764    variable REF_FILENAME to the simple debug file name as given by sinput.  */
8765
8766 bool
8767 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
8768 {
8769   if (Sloc == No_Location)
8770     return false;
8771
8772   if (Sloc <= Standard_Location)
8773     {
8774       *locus = BUILTINS_LOCATION;
8775       return false;
8776     }
8777   else
8778     {
8779       Source_File_Index file = Get_Source_File_Index (Sloc);
8780       Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
8781       Column_Number column = Get_Column_Number (Sloc);
8782       struct line_map *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
8783
8784       /* We can have zero if pragma Source_Reference is in effect.  */
8785       if (line < 1)
8786         line = 1;
8787
8788       /* Translate the location.  */
8789       *locus = linemap_position_for_line_and_column (map, line, column);
8790     }
8791
8792   ref_filename
8793     = IDENTIFIER_POINTER
8794       (get_identifier
8795        (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
8796
8797   return true;
8798 }
8799
8800 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
8801    don't do anything if it doesn't correspond to a source location.  */
8802
8803 static void
8804 set_expr_location_from_node (tree node, Node_Id gnat_node)
8805 {
8806   location_t locus;
8807
8808   if (!Sloc_to_locus (Sloc (gnat_node), &locus))
8809     return;
8810
8811   SET_EXPR_LOCATION (node, locus);
8812 }
8813
8814 /* More elaborate version of set_expr_location_from_node to be used in more
8815    general contexts, for example the result of the translation of a generic
8816    GNAT node.  */
8817
8818 static void
8819 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
8820 {
8821   /* Set the location information on the node if it is a real expression.
8822      References can be reused for multiple GNAT nodes and they would get
8823      the location information of their last use.  Also make sure not to
8824      overwrite an existing location as it is probably more precise.  */
8825
8826   switch (TREE_CODE (node))
8827     {
8828     CASE_CONVERT:
8829     case NON_LVALUE_EXPR:
8830       break;
8831
8832     case COMPOUND_EXPR:
8833       if (EXPR_P (TREE_OPERAND (node, 1)))
8834         set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
8835
8836       /* ... fall through ... */
8837
8838     default:
8839       if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
8840         {
8841           set_expr_location_from_node (node, gnat_node);
8842           set_end_locus_from_node (node, gnat_node);
8843         }
8844       break;
8845     }
8846 }
8847 \f
8848 /* Return a colon-separated list of encodings contained in encoded Ada
8849    name.  */
8850
8851 static const char *
8852 extract_encoding (const char *name)
8853 {
8854   char *encoding = (char *) ggc_alloc_atomic (strlen (name));
8855   get_encoding (name, encoding);
8856   return encoding;
8857 }
8858
8859 /* Extract the Ada name from an encoded name.  */
8860
8861 static const char *
8862 decode_name (const char *name)
8863 {
8864   char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
8865   __gnat_decode (name, decoded, 0);
8866   return decoded;
8867 }
8868 \f
8869 /* Post an error message.  MSG is the error message, properly annotated.
8870    NODE is the node at which to post the error and the node to use for the
8871    '&' substitution.  */
8872
8873 void
8874 post_error (const char *msg, Node_Id node)
8875 {
8876   String_Template temp;
8877   Fat_Pointer fp;
8878
8879   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
8880   fp.Array = msg, fp.Bounds = &temp;
8881   if (Present (node))
8882     Error_Msg_N (fp, node);
8883 }
8884
8885 /* Similar to post_error, but NODE is the node at which to post the error and
8886    ENT is the node to use for the '&' substitution.  */
8887
8888 void
8889 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
8890 {
8891   String_Template temp;
8892   Fat_Pointer fp;
8893
8894   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
8895   fp.Array = msg, fp.Bounds = &temp;
8896   if (Present (node))
8897     Error_Msg_NE (fp, node, ent);
8898 }
8899
8900 /* Similar to post_error_ne, but NUM is the number to use for the '^'.  */
8901
8902 void
8903 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
8904 {
8905   Error_Msg_Uint_1 = UI_From_Int (num);
8906   post_error_ne (msg, node, ent);
8907 }
8908
8909 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
8910    location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
8911    most sense.  Return true if a sensible assignment was performed.  */
8912
8913 static bool
8914 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
8915 {
8916   Node_Id gnat_end_label = Empty;
8917   location_t end_locus;
8918
8919   /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
8920      end_locus when there is one.  We consider only GNAT nodes with a possible
8921      End_Label attached.  If the End_Label actually was unassigned, fallback
8922      on the orginal node.  We'd better assign an explicit sloc associated with
8923      the outer construct in any case.  */
8924
8925   switch (Nkind (gnat_node))
8926     {
8927     case N_Package_Body:
8928     case N_Subprogram_Body:
8929     case N_Block_Statement:
8930       gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
8931       break;
8932
8933     case N_Package_Declaration:
8934       gnat_end_label = End_Label (Specification (gnat_node));
8935       break;
8936
8937     default:
8938       return false;
8939     }
8940
8941   gnat_node = Present (gnat_end_label) ? gnat_end_label : gnat_node;
8942
8943   /* Some expanded subprograms have neither an End_Label nor a Sloc
8944      attached.  Notify that to callers.  */
8945
8946   if (!Sloc_to_locus (Sloc (gnat_node), &end_locus))
8947     return false;
8948
8949   switch (TREE_CODE (gnu_node))
8950     {
8951     case BIND_EXPR:
8952       BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
8953       return true;
8954
8955     case FUNCTION_DECL:
8956       DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
8957       return true;
8958
8959     default:
8960       return false;
8961     }
8962 }
8963 \f
8964 /* Similar to post_error_ne, but T is a GCC tree representing the number to
8965    write.  If T represents a constant, the text inside curly brackets in
8966    MSG will be output (presumably including a '^').  Otherwise it will not
8967    be output and the text inside square brackets will be output instead.  */
8968
8969 void
8970 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
8971 {
8972   char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
8973   char start_yes, end_yes, start_no, end_no;
8974   const char *p;
8975   char *q;
8976
8977   if (TREE_CODE (t) == INTEGER_CST)
8978     {
8979       Error_Msg_Uint_1 = UI_From_gnu (t);
8980       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
8981     }
8982   else
8983     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
8984
8985   for (p = msg, q = new_msg; *p; p++)
8986     {
8987       if (*p == start_yes)
8988         for (p++; *p != end_yes; p++)
8989           *q++ = *p;
8990       else if (*p == start_no)
8991         for (p++; *p != end_no; p++)
8992           ;
8993       else
8994         *q++ = *p;
8995     }
8996
8997   *q = 0;
8998
8999   post_error_ne (new_msg, node, ent);
9000 }
9001
9002 /* Similar to post_error_ne_tree, but NUM is a second integer to write.  */
9003
9004 void
9005 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
9006                       int num)
9007 {
9008   Error_Msg_Uint_2 = UI_From_Int (num);
9009   post_error_ne_tree (msg, node, ent, t);
9010 }
9011 \f
9012 /* Initialize the table that maps GNAT codes to GCC codes for simple
9013    binary and unary operations.  */
9014
9015 static void
9016 init_code_table (void)
9017 {
9018   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
9019   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
9020
9021   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
9022   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
9023   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
9024   gnu_codes[N_Op_Eq] = EQ_EXPR;
9025   gnu_codes[N_Op_Ne] = NE_EXPR;
9026   gnu_codes[N_Op_Lt] = LT_EXPR;
9027   gnu_codes[N_Op_Le] = LE_EXPR;
9028   gnu_codes[N_Op_Gt] = GT_EXPR;
9029   gnu_codes[N_Op_Ge] = GE_EXPR;
9030   gnu_codes[N_Op_Add] = PLUS_EXPR;
9031   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
9032   gnu_codes[N_Op_Multiply] = MULT_EXPR;
9033   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
9034   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
9035   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
9036   gnu_codes[N_Op_Abs] = ABS_EXPR;
9037   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
9038   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
9039   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
9040   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
9041   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
9042   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
9043 }
9044
9045 /* Return a label to branch to for the exception type in KIND or NULL_TREE
9046    if none.  */
9047
9048 tree
9049 get_exception_label (char kind)
9050 {
9051   if (kind == N_Raise_Constraint_Error)
9052     return VEC_last (tree, gnu_constraint_error_label_stack);
9053   else if (kind == N_Raise_Storage_Error)
9054     return VEC_last (tree, gnu_storage_error_label_stack);
9055   else if (kind == N_Raise_Program_Error)
9056     return VEC_last (tree, gnu_program_error_label_stack);
9057   else
9058     return NULL_TREE;
9059 }
9060
9061 /* Return the decl for the current elaboration procedure.  */
9062
9063 tree
9064 get_elaboration_procedure (void)
9065 {
9066   return VEC_last (tree, gnu_elab_proc_stack);
9067 }
9068
9069 #include "gt-ada-trans.h"