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