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-2011, 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
  38 #include "ada.h"
  39 #include "adadecode.h"
  40 #include "types.h"
  41 #include "atree.h"
  42 #include "elists.h"
  43 #include "namet.h"
  44 #include "nlists.h"
  45 #include "snames.h"
  46 #include "stringt.h"
  47 #include "uintp.h"
  48 #include "urealp.h"
  49 #include "fe.h"
  50 #include "sinfo.h"
  51 #include "einfo.h"
  52 #include "gadaint.h"
  53 #include "ada-tree.h"
  54 #include "gigi.h"
  55
  56 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
  57    for fear of running out of stack space.  If we need more, we use xmalloc
  58    instead.  */
  59 #define ALLOCA_THRESHOLD 1000
  60
  61 /* Let code below know whether we are targetting VMS without need of
  62    intrusive preprocessor directives.  */
  63 #ifndef TARGET_ABI_OPEN_VMS
  64 #define TARGET_ABI_OPEN_VMS 0
  65 #endif
  66
  67 /* In configurations where blocks have no end_locus attached, just
  68    sink assignments into a dummy global.  */
  69 #ifndef BLOCK_SOURCE_END_LOCATION
  70 static location_t block_end_locus_sink;
  71 #define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink
  72 #endif
  73
  74 /* For efficient float-to-int rounding, it is necessary to know whether
  75    floating-point arithmetic may use wider intermediate results.  When
  76    FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
  77    that arithmetic does not widen if double precision is emulated.  */
  78 #ifndef FP_ARITH_MAY_WIDEN
  79 #if defined(HAVE_extendsfdf2)
  80 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
  81 #else
  82 #define FP_ARITH_MAY_WIDEN 0
  83 #endif
  84 #endif
  85
  86 /* Pointers to front-end tables accessed through macros.  */
  87 struct Node *Nodes_Ptr;
  88 Node_Id *Next_Node_Ptr;
  89 Node_Id *Prev_Node_Ptr;
  90 struct Elist_Header *Elists_Ptr;
  91 struct Elmt_Item *Elmts_Ptr;
  92 struct String_Entry *Strings_Ptr;
  93 Char_Code *String_Chars_Ptr;
  94 struct List_Header *List_Headers_Ptr;
  95
  96 /* Highest number in the front-end node table.  */
  97 int max_gnat_nodes;
  98
  99 /* Current node being treated, in case abort called.  */
 100 Node_Id error_gnat_node;
 101
 102 /* True when gigi is being called on an analyzed but unexpanded
 103    tree, and the only purpose of the call is to properly annotate
 104    types with representation information.  */
 105 bool type_annotate_only;
 106
 107 /* Current filename without path.  */
 108 const char *ref_filename;
 109
 110 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
 111    of unconstrained array IN parameters to avoid emitting a great deal of
 112    redundant instructions to recompute them each time.  */
 113 struct GTY (()) parm_attr_d {
 114   int id; /* GTY doesn't like Entity_Id.  */
 115   int dim;
 116   tree first;
 117   tree last;
 118   tree length;
 119 };
 120
 121 typedef struct parm_attr_d *parm_attr;
 122
 123 DEF_VEC_P(parm_attr);
 124 DEF_VEC_ALLOC_P(parm_attr,gc);
 125
 126 struct GTY(()) language_function {
 127   VEC(parm_attr,gc) *parm_attr_cache;
 128 };
 129
 130 #define f_parm_attr_cache \
 131   DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
 132
 133 /* A structure used to gather together information about a statement group.
 134    We use this to gather related statements, for example the "then" part
 135    of a IF.  In the case where it represents a lexical scope, we may also
 136    have a BLOCK node corresponding to it and/or cleanups.  */
 137
 138 struct GTY((chain_next ("%h.previous"))) stmt_group {
 139   struct stmt_group *previous;  /* Previous code group.  */
 140   tree stmt_list;               /* List of statements for this code group.  */
 141   tree block;                   /* BLOCK for this code group, if any.  */
 142   tree cleanups;                /* Cleanups for this code group, if any.  */
 143 };
 144
 145 static GTY(()) struct stmt_group *current_stmt_group;
 146
 147 /* List of unused struct stmt_group nodes.  */
 148 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
 149
 150 /* A structure used to record information on elaboration procedures
 151    we've made and need to process.
 152
 153    ??? gnat_node should be Node_Id, but gengtype gets confused.  */
 154
 155 struct GTY((chain_next ("%h.next"))) elab_info {
 156   struct elab_info *next;       /* Pointer to next in chain.  */
 157   tree elab_proc;               /* Elaboration procedure.  */
 158   int gnat_node;                /* The N_Compilation_Unit.  */
 159 };
 160
 161 static GTY(()) struct elab_info *elab_info_list;
 162
 163 /* Stack of exception pointer variables.  Each entry is the VAR_DECL
 164    that stores the address of the raised exception.  Nonzero means we
 165    are in an exception handler.  Not used in the zero-cost case.  */
 166 static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack;
 167
 168 /* Stack for storing the current elaboration procedure decl.  */
 169 static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack;
 170
 171 /* Stack of labels to be used as a goto target instead of a return in
 172    some functions.  See processing for N_Subprogram_Body.  */
 173 static GTY(()) VEC(tree,gc) *gnu_return_label_stack;
 174
 175 /* Stack of variable for the return value of a function with copy-in/copy-out
 176    parameters.  See processing for N_Subprogram_Body.  */
 177 static GTY(()) VEC(tree,gc) *gnu_return_var_stack;
 178
 179 /* Stack of LOOP_STMT nodes.  */
 180 static GTY(()) VEC(tree,gc) *gnu_loop_label_stack;
 181
 182 /* The stacks for N_{Push,Pop}_*_Label.  */
 183 static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack;
 184 static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack;
 185 static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack;
 186
 187 /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
 188 static enum tree_code gnu_codes[Number_Node_Kinds];
 189
 190 static void init_code_table (void);
 191 static void Compilation_Unit_to_gnu (Node_Id);
 192 static void record_code_position (Node_Id);
 193 static void insert_code_for (Node_Id);
 194 static void add_cleanup (tree, Node_Id);
 195 static void add_stmt_list (List_Id);
 196 static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id);
 197 static tree build_stmt_group (List_Id, bool);
 198 static enum gimplify_status gnat_gimplify_stmt (tree *);
 199 static void elaborate_all_entities (Node_Id);
 200 static void process_freeze_entity (Node_Id);
 201 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
 202 static tree emit_range_check (tree, Node_Id, Node_Id);
 203 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
 204 static tree emit_check (tree, tree, int, Node_Id);
 205 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
 206 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
 207 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
 208 static bool addressable_p (tree, tree);
 209 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 210 static tree extract_values (tree, tree);
 211 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
 212 static tree maybe_implicit_deref (tree);
 213 static void set_expr_location_from_node (tree, Node_Id);
 214 static bool set_end_locus_from_node (tree, Node_Id);
 215 static void set_gnu_expr_location_from_node (tree, Node_Id);
 216 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
 217 static tree build_raise_check (int, tree, enum exception_info_kind);
 218
 219 /* Hooks for debug info back-ends, only supported and used in a restricted set
 220    of configurations.  */
 221 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
 222 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
 223 \f
 224 /* This is the main program of the back-end.  It sets up all the table
 225    structures and then generates code.  */
 226
 227 void
 228 gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
 229       struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
 230       struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
 231       struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
 232       struct List_Header *list_headers_ptr, Nat number_file,
 233       struct File_Info_Type *file_info_ptr,
 234       Entity_Id standard_boolean, Entity_Id standard_integer,
 235       Entity_Id standard_character, Entity_Id standard_long_long_float,
 236       Entity_Id standard_exception_type, Int gigi_operating_mode)
 237 {
 238   Entity_Id gnat_literal;
 239   tree long_long_float_type, exception_type, t;
 240   tree int64_type = gnat_type_for_size (64, 0);
 241   struct elab_info *info;
 242   int i;
 243
 244   max_gnat_nodes = max_gnat_node;
 245
 246   Nodes_Ptr = nodes_ptr;
 247   Next_Node_Ptr = next_node_ptr;
 248   Prev_Node_Ptr = prev_node_ptr;
 249   Elists_Ptr = elists_ptr;
 250   Elmts_Ptr = elmts_ptr;
 251   Strings_Ptr = strings_ptr;
 252   String_Chars_Ptr = string_chars_ptr;
 253   List_Headers_Ptr = list_headers_ptr;
 254
 255   type_annotate_only = (gigi_operating_mode == 1);
 256
 257   gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
 258
 259   /* Declare the name of the compilation unit as the first global
 260      name in order to make the middle-end fully deterministic.  */
 261   t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
 262   first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
 263
 264   for (i = 0; i < number_file; i++)
 265     {
 266       /* Use the identifier table to make a permanent copy of the filename as
 267          the name table gets reallocated after Gigi returns but before all the
 268          debugging information is output.  The __gnat_to_canonical_file_spec
 269          call translates filenames from pragmas Source_Reference that contain
 270          host style syntax not understood by gdb.  */
 271       const char *filename
 272         = IDENTIFIER_POINTER
 273            (get_identifier
 274             (__gnat_to_canonical_file_spec
 275              (Get_Name_String (file_info_ptr[i].File_Name))));
 276
 277       /* We rely on the order isomorphism between files and line maps.  */
 278       gcc_assert ((int) line_table->used == i);
 279
 280       /* We create the line map for a source file at once, with a fixed number
 281          of columns chosen to avoid jumping over the next power of 2.  */
 282       linemap_add (line_table, LC_ENTER, 0, filename, 1);
 283       linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
 284       linemap_position_for_column (line_table, 252 - 1);
 285       linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
 286     }
 287
 288   /* Initialize ourselves.  */
 289   init_code_table ();
 290   init_gnat_to_gnu ();
 291   init_dummy_type ();
 292
 293   /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
 294      errors.  */
 295   if (type_annotate_only)
 296     {
 297       TYPE_SIZE (void_type_node) = bitsize_zero_node;
 298       TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
 299     }
 300
 301   /* Enable GNAT stack checking method if needed */
 302   if (!Stack_Check_Probes_On_Target)
 303     set_stack_check_libfunc ("_gnat_stack_check");
 304
 305   /* Retrieve alignment settings.  */
 306   double_float_alignment = get_target_double_float_alignment ();
 307   double_scalar_alignment = get_target_double_scalar_alignment ();
 308
 309   /* Record the builtin types.  Define `integer' and `character' first so that
 310      dbx will output them first.  */
 311   record_builtin_type ("integer", integer_type_node, false);
 312   record_builtin_type ("character", unsigned_char_type_node, false);
 313   record_builtin_type ("boolean", boolean_type_node, false);
 314   record_builtin_type ("void", void_type_node, false);
 315
 316   /* Save the type we made for integer as the type for Standard.Integer.  */
 317   save_gnu_tree (Base_Type (standard_integer),
 318                  TYPE_NAME (integer_type_node),
 319                  false);
 320
 321   /* Likewise for character as the type for Standard.Character.  */
 322   save_gnu_tree (Base_Type (standard_character),
 323                  TYPE_NAME (unsigned_char_type_node),
 324                  false);
 325
 326   /* Likewise for boolean as the type for Standard.Boolean.  */
 327   save_gnu_tree (Base_Type (standard_boolean),
 328                  TYPE_NAME (boolean_type_node),
 329                  false);
 330   gnat_literal = First_Literal (Base_Type (standard_boolean));
 331   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 332   gcc_assert (t == boolean_false_node);
 333   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 334                        boolean_type_node, t, true, false, false, false,
 335                        NULL, gnat_literal);
 336   DECL_IGNORED_P (t) = 1;
 337   save_gnu_tree (gnat_literal, t, false);
 338   gnat_literal = Next_Literal (gnat_literal);
 339   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 340   gcc_assert (t == boolean_true_node);
 341   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 342                        boolean_type_node, t, true, false, false, false,
 343                        NULL, gnat_literal);
 344   DECL_IGNORED_P (t) = 1;
 345   save_gnu_tree (gnat_literal, t, false);
 346
 347   void_ftype = build_function_type (void_type_node, NULL_TREE);
 348   ptr_void_ftype = build_pointer_type (void_ftype);
 349
 350   /* Now declare run-time functions.  */
 351   t = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
 352
 353   /* malloc is a function declaration tree for a function to allocate
 354      memory.  */
 355   malloc_decl
 356     = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
 357                            build_function_type (ptr_void_type_node,
 358                                                 tree_cons (NULL_TREE,
 359                                                            sizetype, t)),
 360                            NULL_TREE, false, true, true, true, NULL, Empty);
 361   DECL_IS_MALLOC (malloc_decl) = 1;
 362
 363   /* malloc32 is a function declaration tree for a function to allocate
 364      32-bit memory on a 64-bit system.  Needed only on 64-bit VMS.  */
 365   malloc32_decl
 366     = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
 367                            build_function_type (ptr_void_type_node,
 368                                                 tree_cons (NULL_TREE,
 369                                                            sizetype, t)),
 370                            NULL_TREE, false, true, true, true, NULL, Empty);
 371   DECL_IS_MALLOC (malloc32_decl) = 1;
 372
 373   /* free is a function declaration tree for a function to free memory.  */
 374   free_decl
 375     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
 376                            build_function_type (void_type_node,
 377                                                 tree_cons (NULL_TREE,
 378                                                            ptr_void_type_node,
 379                                                            t)),
 380                            NULL_TREE, false, true, true, true, NULL, Empty);
 381
 382   /* This is used for 64-bit multiplication with overflow checking.  */
 383   mulv64_decl
 384     = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
 385                            build_function_type_list (int64_type, int64_type,
 386                                                      int64_type, NULL_TREE),
 387                            NULL_TREE, false, true, true, true, NULL, Empty);
 388
 389   /* Name of the _Parent field in tagged record types.  */
 390   parent_name_id = get_identifier (Get_Name_String (Name_uParent));
 391
 392   /* Name of the Exception_Data type defined in System.Standard_Library.  */
 393   exception_data_name_id
 394     = get_identifier ("system__standard_library__exception_data");
 395
 396   /* Make the types and functions used for exception processing.  */
 397   jmpbuf_type
 398     = build_array_type (gnat_type_for_mode (Pmode, 0),
 399                         build_index_type (size_int (5)));
 400   record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
 401   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
 402
 403   /* Functions to get and set the jumpbuf pointer for the current thread.  */
 404   get_jmpbuf_decl
 405     = create_subprog_decl
 406     (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
 407      NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
 408      NULL_TREE, false, true, true, true, NULL, Empty);
 409   DECL_IGNORED_P (get_jmpbuf_decl) = 1;
 410
 411   set_jmpbuf_decl
 412     = create_subprog_decl
 413     (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
 414      NULL_TREE,
 415      build_function_type (void_type_node,
 416                           tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
 417      NULL_TREE, false, true, true, true, NULL, Empty);
 418   DECL_IGNORED_P (set_jmpbuf_decl) = 1;
 419
 420   /* setjmp returns an integer and has one operand, which is a pointer to
 421      a jmpbuf.  */
 422   setjmp_decl
 423     = create_subprog_decl
 424       (get_identifier ("__builtin_setjmp"), NULL_TREE,
 425        build_function_type (integer_type_node,
 426                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, t)),
 427        NULL_TREE, false, true, true, true, NULL, Empty);
 428   DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
 429   DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
 430
 431   /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
 432      address.  */
 433   update_setjmp_buf_decl
 434     = create_subprog_decl
 435       (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
 436        build_function_type (void_type_node,
 437                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, t)),
 438        NULL_TREE, false, true, true, true, NULL, Empty);
 439   DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
 440   DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
 441
 442   /* Hooks to call when entering/leaving an exception handler.  */
 443   begin_handler_decl
 444     = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
 445                            build_function_type (void_type_node,
 446                                                 tree_cons (NULL_TREE,
 447                                                            ptr_void_type_node,
 448                                                            t)),
 449                            NULL_TREE, false, true, true, true, NULL, Empty);
 450   DECL_IGNORED_P (begin_handler_decl) = 1;
 451
 452   end_handler_decl
 453     = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
 454                            build_function_type (void_type_node,
 455                                                 tree_cons (NULL_TREE,
 456                                                            ptr_void_type_node,
 457                                                            t)),
 458                            NULL_TREE, false, true, true, true, NULL, Empty);
 459   DECL_IGNORED_P (end_handler_decl) = 1;
 460
 461   /* If in no exception handlers mode, all raise statements are redirected to
 462      __gnat_last_chance_handler.  No need to redefine raise_nodefer_decl since
 463      this procedure will never be called in this mode.  */
 464   if (No_Exception_Handlers_Set ())
 465     {
 466       tree decl
 467         = create_subprog_decl
 468           (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
 469            build_function_type (void_type_node,
 470                                 tree_cons (NULL_TREE,
 471                                            build_pointer_type
 472                                            (unsigned_char_type_node),
 473                                            tree_cons (NULL_TREE,
 474                                                       integer_type_node,
 475                                                       t))),
 476            NULL_TREE, false, true, true, true, NULL, Empty);
 477       TREE_THIS_VOLATILE (decl) = 1;
 478       TREE_SIDE_EFFECTS (decl) = 1;
 479       TREE_TYPE (decl)
 480         = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
 481       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 482         gnat_raise_decls[i] = decl;
 483     }
 484   else
 485     {
 486       /* Otherwise, make one decl for each exception reason.  */
 487       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 488         gnat_raise_decls[i] = build_raise_check (i, t, exception_simple);
 489       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
 490         gnat_raise_decls_ext[i]
 491           = build_raise_check (i, t,
 492                                i == CE_Index_Check_Failed
 493                                || i == CE_Range_Check_Failed
 494                                || i == CE_Invalid_Data
 495                                ? exception_range : exception_column);
 496     }
 497
 498   /* Set the types that GCC and Gigi use from the front end.  */
 499   exception_type
 500     = gnat_to_gnu_entity (Base_Type (standard_exception_type),  NULL_TREE, 0);
 501   except_type_node = TREE_TYPE (exception_type);
 502
 503   /* Make other functions used for exception processing.  */
 504   get_excptr_decl
 505     = create_subprog_decl
 506     (get_identifier ("system__soft_links__get_gnat_exception"),
 507      NULL_TREE,
 508      build_function_type (build_pointer_type (except_type_node), NULL_TREE),
 509      NULL_TREE, false, true, true, true, NULL, Empty);
 510
 511   raise_nodefer_decl
 512     = create_subprog_decl
 513       (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
 514        build_function_type (void_type_node,
 515                             tree_cons (NULL_TREE,
 516                                        build_pointer_type (except_type_node),
 517                                        t)),
 518        NULL_TREE, false, true, true, true, NULL, Empty);
 519
 520   /* Indicate that these never return.  */
 521   TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
 522   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
 523   TREE_TYPE (raise_nodefer_decl)
 524     = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
 525                             TYPE_QUAL_VOLATILE);
 526
 527   /* Build the special descriptor type and its null node if needed.  */
 528   if (TARGET_VTABLE_USES_DESCRIPTORS)
 529     {
 530       tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
 531       tree field_list = NULL_TREE;
 532       int j;
 533       VEC(constructor_elt,gc) *null_vec = NULL;
 534       constructor_elt *elt;
 535
 536       fdesc_type_node = make_node (RECORD_TYPE);
 537       VEC_safe_grow (constructor_elt, gc, null_vec,
 538                      TARGET_VTABLE_USES_DESCRIPTORS);
 539       elt = (VEC_address (constructor_elt,null_vec)
 540              + TARGET_VTABLE_USES_DESCRIPTORS - 1);
 541
 542       for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
 543         {
 544           tree field
 545             = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
 546                                  NULL_TREE, NULL_TREE, 0, 1);
 547           TREE_CHAIN (field) = field_list;
 548           field_list = field;
 549           elt->index = field;
 550           elt->value = null_node;
 551           elt--;
 552         }
 553
 554       finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
 555       record_builtin_type ("descriptor", fdesc_type_node, true);
 556       null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
 557     }
 558
 559   long_long_float_type
 560     = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
 561
 562   if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
 563     {
 564       /* In this case, the builtin floating point types are VAX float,
 565          so make up a type for use.  */
 566       longest_float_type_node = make_node (REAL_TYPE);
 567       TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
 568       layout_type (longest_float_type_node);
 569       record_builtin_type ("longest float type", longest_float_type_node,
 570                            false);
 571     }
 572   else
 573     longest_float_type_node = TREE_TYPE (long_long_float_type);
 574
 575   /* Dummy objects to materialize "others" and "all others" in the exception
 576      tables.  These are exported by a-exexpr.adb, so see this unit for the
 577      types to use.  */
 578   others_decl
 579     = create_var_decl (get_identifier ("OTHERS"),
 580                        get_identifier ("__gnat_others_value"),
 581                        integer_type_node, NULL_TREE, true, false, true, false,
 582                        NULL, Empty);
 583
 584   all_others_decl
 585     = create_var_decl (get_identifier ("ALL_OTHERS"),
 586                        get_identifier ("__gnat_all_others_value"),
 587                        integer_type_node, NULL_TREE, true, false, true, false,
 588                        NULL, Empty);
 589
 590   main_identifier_node = get_identifier ("main");
 591
 592   /* Install the builtins we might need, either internally or as
 593      user available facilities for Intrinsic imports.  */
 594   gnat_install_builtins ();
 595
 596   VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE);
 597   VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE);
 598   VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE);
 599   VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE);
 600
 601   /* Process any Pragma Ident for the main unit.  */
 602 #ifdef ASM_OUTPUT_IDENT
 603   if (Present (Ident_String (Main_Unit)))
 604     ASM_OUTPUT_IDENT
 605       (asm_out_file,
 606        TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
 607 #endif
 608
 609   /* If we are using the GCC exception mechanism, let GCC know.  */
 610   if (Exception_Mechanism == Back_End_Exceptions)
 611     gnat_init_gcc_eh ();
 612
 613   /* Now translate the compilation unit proper.  */
 614   Compilation_Unit_to_gnu (gnat_root);
 615
 616   /* Finally see if we have any elaboration procedures to deal with.  */
 617   for (info = elab_info_list; info; info = info->next)
 618     {
 619       tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
 620
 621       /* We should have a BIND_EXPR but it may not have any statements in it.
 622          If it doesn't have any, we have nothing to do except for setting the
 623          flag on the GNAT node.  Otherwise, process the function as others.  */
 624       gnu_stmts = gnu_body;
 625       if (TREE_CODE (gnu_stmts) == BIND_EXPR)
 626         gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
 627       if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
 628         Set_Has_No_Elaboration_Code (info->gnat_node, 1);
 629       else
 630         {
 631           begin_subprog_body (info->elab_proc);
 632           end_subprog_body (gnu_body);
 633         }
 634     }
 635
 636   /* We cannot track the location of errors past this point.  */
 637   error_gnat_node = Empty;
 638 }
 639 \f
 640 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
 641    CHECK (if EXTENDED is false), or __gnat_rcheck_xx_ext (if EXTENDED is
 642    true).  */
 643
 644 static tree
 645 build_raise_check (int check, tree void_tree, enum exception_info_kind kind)
 646 {
 647   char name[21];
 648   tree result;
 649
 650   if (kind != exception_simple)
 651     {
 652       sprintf (name, "__gnat_rcheck_%.2d_ext", check);
 653       result
 654         = create_subprog_decl
 655           (get_identifier (name), NULL_TREE,
 656            build_function_type
 657            (void_type_node,
 658             tree_cons
 659             (NULL_TREE, build_pointer_type (unsigned_char_type_node),
 660              tree_cons (NULL_TREE, integer_type_node,
 661                         tree_cons (NULL_TREE, integer_type_node,
 662                                    kind == exception_column
 663                                    ? void_tree
 664                                    : tree_cons (NULL_TREE, integer_type_node,
 665                                                 tree_cons (NULL_TREE,
 666                                                            integer_type_node,
 667                                                            void_tree)))))),
 668            NULL_TREE, false, true, true, true, NULL, Empty);
 669     }
 670   else
 671     {
 672       sprintf (name, "__gnat_rcheck_%.2d", check);
 673       result
 674         = create_subprog_decl
 675           (get_identifier (name), NULL_TREE,
 676            build_function_type
 677            (void_type_node,
 678             tree_cons
 679             (NULL_TREE, build_pointer_type (unsigned_char_type_node),
 680              tree_cons (NULL_TREE, integer_type_node, void_tree))),
 681            NULL_TREE, false, true, true, true, NULL, Empty);
 682     }
 683
 684   TREE_THIS_VOLATILE (result) = 1;
 685   TREE_SIDE_EFFECTS (result) = 1;
 686   TREE_TYPE (result)
 687     = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE);
 688
 689   return result;
 690 }
 691 \f
 692 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
 693    an N_Attribute_Reference.  */
 694
 695 static int
 696 lvalue_required_for_attribute_p (Node_Id gnat_node)
 697 {
 698   switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
 699     {
 700     case Attr_Pos:
 701     case Attr_Val:
 702     case Attr_Pred:
 703     case Attr_Succ:
 704     case Attr_First:
 705     case Attr_Last:
 706     case Attr_Range_Length:
 707     case Attr_Length:
 708     case Attr_Object_Size:
 709     case Attr_Value_Size:
 710     case Attr_Component_Size:
 711     case Attr_Max_Size_In_Storage_Elements:
 712     case Attr_Min:
 713     case Attr_Max:
 714     case Attr_Null_Parameter:
 715     case Attr_Passed_By_Reference:
 716     case Attr_Mechanism_Code:
 717       return 0;
 718
 719     case Attr_Address:
 720     case Attr_Access:
 721     case Attr_Unchecked_Access:
 722     case Attr_Unrestricted_Access:
 723     case Attr_Code_Address:
 724     case Attr_Pool_Address:
 725     case Attr_Size:
 726     case Attr_Alignment:
 727     case Attr_Bit_Position:
 728     case Attr_Position:
 729     case Attr_First_Bit:
 730     case Attr_Last_Bit:
 731     case Attr_Bit:
 732     default:
 733       return 1;
 734     }
 735 }
 736
 737 /* Return a positive value if an lvalue is required for GNAT_NODE.  GNU_TYPE
 738    is the type that will be used for GNAT_NODE in the translated GNU tree.
 739    CONSTANT indicates whether the underlying object represented by GNAT_NODE
 740    is constant in the Ada sense.  If it is, ADDRESS_OF_CONSTANT indicates
 741    whether its value is the address of a constant and ALIASED whether it is
 742    aliased.  If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
 743
 744    The function climbs up the GNAT tree starting from the node and returns 1
 745    upon encountering a node that effectively requires an lvalue downstream.
 746    It returns int instead of bool to facilitate usage in non-purely binary
 747    logic contexts.  */
 748
 749 static int
 750 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
 751                    bool address_of_constant, bool aliased)
 752 {
 753   Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
 754
 755   switch (Nkind (gnat_parent))
 756     {
 757     case N_Reference:
 758       return 1;
 759
 760     case N_Attribute_Reference:
 761       return lvalue_required_for_attribute_p (gnat_parent);
 762
 763     case N_Parameter_Association:
 764     case N_Function_Call:
 765     case N_Procedure_Call_Statement:
 766       /* If the parameter is by reference, an lvalue is required.  */
 767       return (!constant
 768               || must_pass_by_ref (gnu_type)
 769               || default_pass_by_ref (gnu_type));
 770
 771     case N_Indexed_Component:
 772       /* Only the array expression can require an lvalue.  */
 773       if (Prefix (gnat_parent) != gnat_node)
 774         return 0;
 775
 776       /* ??? Consider that referencing an indexed component with a
 777          non-constant index forces the whole aggregate to memory.
 778          Note that N_Integer_Literal is conservative, any static
 779          expression in the RM sense could probably be accepted.  */
 780       for (gnat_temp = First (Expressions (gnat_parent));
 781            Present (gnat_temp);
 782            gnat_temp = Next (gnat_temp))
 783         if (Nkind (gnat_temp) != N_Integer_Literal)
 784           return 1;
 785
 786       /* ... fall through ... */
 787
 788     case N_Slice:
 789       /* Only the array expression can require an lvalue.  */
 790       if (Prefix (gnat_parent) != gnat_node)
 791         return 0;
 792
 793       aliased |= Has_Aliased_Components (Etype (gnat_node));
 794       return lvalue_required_p (gnat_parent, gnu_type, constant,
 795                                 address_of_constant, aliased);
 796
 797     case N_Selected_Component:
 798       aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
 799       return lvalue_required_p (gnat_parent, gnu_type, constant,
 800                                 address_of_constant, aliased);
 801
 802     case N_Object_Renaming_Declaration:
 803       /* We need to make a real renaming only if the constant object is
 804          aliased or if we may use a renaming pointer; otherwise we can
 805          optimize and return the rvalue.  We make an exception if the object
 806          is an identifier since in this case the rvalue can be propagated
 807          attached to the CONST_DECL.  */
 808       return (!constant
 809               || aliased
 810               /* This should match the constant case of the renaming code.  */
 811               || Is_Composite_Type
 812                  (Underlying_Type (Etype (Name (gnat_parent))))
 813               || Nkind (Name (gnat_parent)) == N_Identifier);
 814
 815     case N_Object_Declaration:
 816       /* We cannot use a constructor if this is an atomic object because
 817          the actual assignment might end up being done component-wise.  */
 818       return (!constant
 819               ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 820                  && Is_Atomic (Defining_Entity (gnat_parent)))
 821               /* We don't use a constructor if this is a class-wide object
 822                  because the effective type of the object is the equivalent
 823                  type of the class-wide subtype and it smashes most of the
 824                  data into an array of bytes to which we cannot convert.  */
 825               || Ekind ((Etype (Defining_Entity (gnat_parent))))
 826                  == E_Class_Wide_Subtype);
 827
 828     case N_Assignment_Statement:
 829       /* We cannot use a constructor if the LHS is an atomic object because
 830          the actual assignment might end up being done component-wise.  */
 831       return (!constant
 832               || Name (gnat_parent) == gnat_node
 833               || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 834                   && Is_Atomic (Entity (Name (gnat_parent)))));
 835
 836     case N_Unchecked_Type_Conversion:
 837         if (!constant)
 838           return 1;
 839
 840       /* ... fall through ... */
 841
 842     case N_Type_Conversion:
 843     case N_Qualified_Expression:
 844       /* We must look through all conversions because we may need to bypass
 845          an intermediate conversion that is meant to be purely formal.  */
 846      return lvalue_required_p (gnat_parent,
 847                                get_unpadded_type (Etype (gnat_parent)),
 848                                constant, address_of_constant, aliased);
 849
 850     case N_Allocator:
 851       /* We should only reach here through the N_Qualified_Expression case.
 852          Force an lvalue for composite types since a block-copy to the newly
 853          allocated area of memory is made.  */
 854       return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
 855
 856    case N_Explicit_Dereference:
 857       /* We look through dereferences for address of constant because we need
 858          to handle the special cases listed above.  */
 859       if (constant && address_of_constant)
 860         return lvalue_required_p (gnat_parent,
 861                                   get_unpadded_type (Etype (gnat_parent)),
 862                                   true, false, true);
 863
 864       /* ... fall through ... */
 865
 866     default:
 867       return 0;
 868     }
 869
 870   gcc_unreachable ();
 871 }
 872
 873 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
 874    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer
 875    to where we should place the result type.  */
 876
 877 static tree
 878 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 879 {
 880   Node_Id gnat_temp, gnat_temp_type;
 881   tree gnu_result, gnu_result_type;
 882
 883   /* Whether we should require an lvalue for GNAT_NODE.  Needed in
 884      specific circumstances only, so evaluated lazily.  < 0 means
 885      unknown, > 0 means known true, 0 means known false.  */
 886   int require_lvalue = -1;
 887
 888   /* If GNAT_NODE is a constant, whether we should use the initialization
 889      value instead of the constant entity, typically for scalars with an
 890      address clause when the parent doesn't require an lvalue.  */
 891   bool use_constant_initializer = false;
 892
 893   /* If the Etype of this node does not equal the Etype of the Entity,
 894      something is wrong with the entity map, probably in generic
 895      instantiation. However, this does not apply to types. Since we sometime
 896      have strange Ekind's, just do this test for objects. Also, if the Etype of
 897      the Entity is private, the Etype of the N_Identifier is allowed to be the
 898      full type and also we consider a packed array type to be the same as the
 899      original type. Similarly, a class-wide type is equivalent to a subtype of
 900      itself. Finally, if the types are Itypes, one may be a copy of the other,
 901      which is also legal.  */
 902   gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
 903                ? gnat_node : Entity (gnat_node));
 904   gnat_temp_type = Etype (gnat_temp);
 905
 906   gcc_assert (Etype (gnat_node) == gnat_temp_type
 907               || (Is_Packed (gnat_temp_type)
 908                   && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
 909               || (Is_Class_Wide_Type (Etype (gnat_node)))
 910               || (IN (Ekind (gnat_temp_type), Private_Kind)
 911                   && Present (Full_View (gnat_temp_type))
 912                   && ((Etype (gnat_node) == Full_View (gnat_temp_type))
 913                       || (Is_Packed (Full_View (gnat_temp_type))
 914                           && (Etype (gnat_node)
 915                               == Packed_Array_Type (Full_View
 916                                                     (gnat_temp_type))))))
 917               || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
 918               || !(Ekind (gnat_temp) == E_Variable
 919                    || Ekind (gnat_temp) == E_Component
 920                    || Ekind (gnat_temp) == E_Constant
 921                    || Ekind (gnat_temp) == E_Loop_Parameter
 922                    || IN (Ekind (gnat_temp), Formal_Kind)));
 923
 924   /* If this is a reference to a deferred constant whose partial view is an
 925      unconstrained private type, the proper type is on the full view of the
 926      constant, not on the full view of the type, which may be unconstrained.
 927
 928      This may be a reference to a type, for example in the prefix of the
 929      attribute Position, generated for dispatching code (see Make_DT in
 930      exp_disp,adb). In that case we need the type itself, not is parent,
 931      in particular if it is a derived type  */
 932   if (Is_Private_Type (gnat_temp_type)
 933       && Has_Unknown_Discriminants (gnat_temp_type)
 934       && Ekind (gnat_temp) == E_Constant
 935       && Present (Full_View (gnat_temp)))
 936     {
 937       gnat_temp = Full_View (gnat_temp);
 938       gnat_temp_type = Etype (gnat_temp);
 939     }
 940   else
 941     {
 942       /* We want to use the Actual_Subtype if it has already been elaborated,
 943          otherwise the Etype.  Avoid using Actual_Subtype for packed arrays to
 944          simplify things.  */
 945       if ((Ekind (gnat_temp) == E_Constant
 946            || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
 947           && !(Is_Array_Type (Etype (gnat_temp))
 948                && Present (Packed_Array_Type (Etype (gnat_temp))))
 949           && Present (Actual_Subtype (gnat_temp))
 950           && present_gnu_tree (Actual_Subtype (gnat_temp)))
 951         gnat_temp_type = Actual_Subtype (gnat_temp);
 952       else
 953         gnat_temp_type = Etype (gnat_node);
 954     }
 955
 956   /* Expand the type of this identifier first, in case it is an enumeral
 957      literal, which only get made when the type is expanded.  There is no
 958      order-of-elaboration issue here.  */
 959   gnu_result_type = get_unpadded_type (gnat_temp_type);
 960
 961   /* If this is a non-imported scalar constant with an address clause,
 962      retrieve the value instead of a pointer to be dereferenced unless
 963      an lvalue is required.  This is generally more efficient and actually
 964      required if this is a static expression because it might be used
 965      in a context where a dereference is inappropriate, such as a case
 966      statement alternative or a record discriminant.  There is no possible
 967      volatile-ness short-circuit here since Volatile constants must be
 968      imported per C.6.  */
 969   if (Ekind (gnat_temp) == E_Constant
 970       && Is_Scalar_Type (gnat_temp_type)
 971       && !Is_Imported (gnat_temp)
 972       && Present (Address_Clause (gnat_temp)))
 973     {
 974       require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
 975                                           false, Is_Aliased (gnat_temp));
 976       use_constant_initializer = !require_lvalue;
 977     }
 978
 979   if (use_constant_initializer)
 980     {
 981       /* If this is a deferred constant, the initializer is attached to
 982          the full view.  */
 983       if (Present (Full_View (gnat_temp)))
 984         gnat_temp = Full_View (gnat_temp);
 985
 986       gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
 987     }
 988   else
 989     gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
 990
 991   /* Some objects (such as parameters passed by reference, globals of
 992      variable size, and renamed objects) actually represent the address
 993      of the object.  In that case, we must do the dereference.  Likewise,
 994      deal with parameters to foreign convention subprograms.  */
 995   if (DECL_P (gnu_result)
 996       && (DECL_BY_REF_P (gnu_result)
 997           || (TREE_CODE (gnu_result) == PARM_DECL
 998               && DECL_BY_COMPONENT_PTR_P (gnu_result))))
 999     {
1000       const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1001       tree renamed_obj;
1002
1003       if (TREE_CODE (gnu_result) == PARM_DECL
1004           && DECL_BY_DOUBLE_REF_P (gnu_result))
1005         {
1006           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1007           if (TREE_CODE (gnu_result) == INDIRECT_REF)
1008             TREE_THIS_NOTRAP (gnu_result) = 1;
1009         }
1010
1011       if (TREE_CODE (gnu_result) == PARM_DECL
1012           && DECL_BY_COMPONENT_PTR_P (gnu_result))
1013         {
1014           gnu_result
1015             = build_unary_op (INDIRECT_REF, NULL_TREE,
1016                               convert (build_pointer_type (gnu_result_type),
1017                                        gnu_result));
1018           if (TREE_CODE (gnu_result) == INDIRECT_REF)
1019             TREE_THIS_NOTRAP (gnu_result) = 1;
1020         }
1021
1022       /* If it's a renaming pointer and we are at the right binding level,
1023          we can reference the renamed object directly, since the renamed
1024          expression has been protected against multiple evaluations.  */
1025       else if (TREE_CODE (gnu_result) == VAR_DECL
1026                && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result))
1027                && (!DECL_RENAMING_GLOBAL_P (gnu_result)
1028                    || global_bindings_p ()))
1029         gnu_result = renamed_obj;
1030
1031       /* Return the underlying CST for a CONST_DECL like a few lines below,
1032          after dereferencing in this case.  */
1033       else if (TREE_CODE (gnu_result) == CONST_DECL)
1034         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
1035                                      DECL_INITIAL (gnu_result));
1036
1037       else
1038         {
1039           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1040           if (TREE_CODE (gnu_result) == INDIRECT_REF)
1041             TREE_THIS_NOTRAP (gnu_result) = 1;
1042         }
1043
1044       if (read_only)
1045         TREE_READONLY (gnu_result) = 1;
1046     }
1047
1048   /* The GNAT tree has the type of a function as the type of its result.  Also
1049      use the type of the result if the Etype is a subtype which is nominally
1050      unconstrained.  But remove any padding from the resulting type.  */
1051   if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1052       || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
1053     {
1054       gnu_result_type = TREE_TYPE (gnu_result);
1055       if (TYPE_IS_PADDING_P (gnu_result_type))
1056         gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1057     }
1058
1059   /* If we have a constant declaration and its initializer, try to return the
1060      latter to avoid the need to call fold in lots of places and the need for
1061      elaboration code if this identifier is used as an initializer itself.
1062      Don't do it for aggregate types that contain a placeholder since their
1063      initializers cannot be manipulated easily.  */
1064   if (TREE_CONSTANT (gnu_result)
1065       && DECL_P (gnu_result)
1066       && DECL_INITIAL (gnu_result)
1067       && !(AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
1068            && type_contains_placeholder_p (TREE_TYPE (gnu_result))))
1069     {
1070       bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1071                             && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1072       bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1073                                   && DECL_CONST_ADDRESS_P (gnu_result));
1074
1075       /* If there is a (corresponding) variable or this is the address of a
1076          constant, we only want to return the initializer if an lvalue isn't
1077          required.  Evaluate this now if we have not already done so.  */
1078       if ((!constant_only || address_of_constant) && require_lvalue < 0)
1079         require_lvalue
1080           = lvalue_required_p (gnat_node, gnu_result_type, true,
1081                                address_of_constant, Is_Aliased (gnat_temp));
1082
1083       /* ??? We need to unshare the initializer if the object is external
1084          as such objects are not marked for unsharing if we are not at the
1085          global level.  This should be fixed in add_decl_expr.  */
1086       if ((constant_only && !address_of_constant) || !require_lvalue)
1087         gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
1088     }
1089
1090   *gnu_result_type_p = gnu_result_type;
1091
1092   return gnu_result;
1093 }
1094 \f
1095 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
1096    any statements we generate.  */
1097
1098 static tree
1099 Pragma_to_gnu (Node_Id gnat_node)
1100 {
1101   Node_Id gnat_temp;
1102   tree gnu_result = alloc_stmt_list ();
1103
1104   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1105      annotating types.  */
1106   if (type_annotate_only
1107       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1108     return gnu_result;
1109
1110   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1111     {
1112     case Pragma_Inspection_Point:
1113       /* Do nothing at top level: all such variables are already viewable.  */
1114       if (global_bindings_p ())
1115         break;
1116
1117       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1118            Present (gnat_temp);
1119            gnat_temp = Next (gnat_temp))
1120         {
1121           Node_Id gnat_expr = Expression (gnat_temp);
1122           tree gnu_expr = gnat_to_gnu (gnat_expr);
1123           int use_address;
1124           enum machine_mode mode;
1125           tree asm_constraint = NULL_TREE;
1126 #ifdef ASM_COMMENT_START
1127           char *comment;
1128 #endif
1129
1130           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1131             gnu_expr = TREE_OPERAND (gnu_expr, 0);
1132
1133           /* Use the value only if it fits into a normal register,
1134              otherwise use the address.  */
1135           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1136           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1137                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1138                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1139
1140           if (use_address)
1141             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1142
1143 #ifdef ASM_COMMENT_START
1144           comment = concat (ASM_COMMENT_START,
1145                             " inspection point: ",
1146                             Get_Name_String (Chars (gnat_expr)),
1147                             use_address ? " address" : "",
1148                             " is in %0",
1149                             NULL);
1150           asm_constraint = build_string (strlen (comment), comment);
1151           free (comment);
1152 #endif
1153           gnu_expr = build5 (ASM_EXPR, void_type_node,
1154                              asm_constraint,
1155                              NULL_TREE,
1156                              tree_cons
1157                              (build_tree_list (NULL_TREE,
1158                                                build_string (1, "g")),
1159                               gnu_expr, NULL_TREE),
1160                              NULL_TREE, NULL_TREE);
1161           ASM_VOLATILE_P (gnu_expr) = 1;
1162           set_expr_location_from_node (gnu_expr, gnat_node);
1163           append_to_statement_list (gnu_expr, &gnu_result);
1164         }
1165       break;
1166
1167     case Pragma_Optimize:
1168       switch (Chars (Expression
1169                      (First (Pragma_Argument_Associations (gnat_node)))))
1170         {
1171         case Name_Time:  case Name_Space:
1172           if (!optimize)
1173             post_error ("insufficient -O value?", gnat_node);
1174           break;
1175
1176         case Name_Off:
1177           if (optimize)
1178             post_error ("must specify -O0?", gnat_node);
1179           break;
1180
1181         default:
1182           gcc_unreachable ();
1183         }
1184       break;
1185
1186     case Pragma_Reviewable:
1187       if (write_symbols == NO_DEBUG)
1188         post_error ("must specify -g?", gnat_node);
1189       break;
1190     }
1191
1192   return gnu_result;
1193 }
1194 \f
1195 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1196    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
1197    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
1198
1199 static tree
1200 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1201 {
1202   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1203   tree gnu_type = TREE_TYPE (gnu_prefix);
1204   tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1205   bool prefix_unused = false;
1206
1207   /* If the input is a NULL_EXPR, make a new one.  */
1208   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1209     {
1210       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1211       *gnu_result_type_p = gnu_result_type;
1212       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1213     }
1214
1215   switch (attribute)
1216     {
1217     case Attr_Pos:
1218     case Attr_Val:
1219       /* These are just conversions since representation clauses for
1220          enumeration types are handled in the front-end.  */
1221       {
1222         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1223         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1224         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1225         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1226                                          checkp, checkp, true, gnat_node);
1227       }
1228       break;
1229
1230     case Attr_Pred:
1231     case Attr_Succ:
1232       /* These just add or subtract the constant 1 since representation
1233          clauses for enumeration types are handled in the front-end.  */
1234       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1235       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1236
1237       if (Do_Range_Check (First (Expressions (gnat_node))))
1238         {
1239           gnu_expr = gnat_protect_expr (gnu_expr);
1240           gnu_expr
1241             = emit_check
1242               (build_binary_op (EQ_EXPR, boolean_type_node,
1243                                 gnu_expr,
1244                                 attribute == Attr_Pred
1245                                 ? TYPE_MIN_VALUE (gnu_result_type)
1246                                 : TYPE_MAX_VALUE (gnu_result_type)),
1247                gnu_expr, CE_Range_Check_Failed, gnat_node);
1248         }
1249
1250       gnu_result
1251         = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1252                            gnu_result_type, gnu_expr,
1253                            convert (gnu_result_type, integer_one_node));
1254       break;
1255
1256     case Attr_Address:
1257     case Attr_Unrestricted_Access:
1258       /* Conversions don't change addresses but can cause us to miss the
1259          COMPONENT_REF case below, so strip them off.  */
1260       gnu_prefix = remove_conversions (gnu_prefix,
1261                                        !Must_Be_Byte_Aligned (gnat_node));
1262
1263       /* If we are taking 'Address of an unconstrained object, this is the
1264          pointer to the underlying array.  */
1265       if (attribute == Attr_Address)
1266         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1267
1268       /* If we are building a static dispatch table, we have to honor
1269          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1270          with the C++ ABI.  We do it in the non-static case as well,
1271          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
1272       else if (TARGET_VTABLE_USES_DESCRIPTORS
1273                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1274         {
1275           tree gnu_field, t;
1276           /* Descriptors can only be built here for top-level functions.  */
1277           bool build_descriptor = (global_bindings_p () != 0);
1278           int i;
1279           VEC(constructor_elt,gc) *gnu_vec = NULL;
1280           constructor_elt *elt;
1281
1282           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1283
1284           /* If we're not going to build the descriptor, we have to retrieve
1285              the one which will be built by the linker (or by the compiler
1286              later if a static chain is requested).  */
1287           if (!build_descriptor)
1288             {
1289               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1290               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1291                                          gnu_result);
1292               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1293             }
1294
1295           VEC_safe_grow (constructor_elt, gc, gnu_vec,
1296                          TARGET_VTABLE_USES_DESCRIPTORS);
1297           elt = (VEC_address (constructor_elt, gnu_vec)
1298                  + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1299           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1300                i < TARGET_VTABLE_USES_DESCRIPTORS;
1301                gnu_field = TREE_CHAIN (gnu_field), i++)
1302             {
1303               if (build_descriptor)
1304                 {
1305                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1306                               build_int_cst (NULL_TREE, i));
1307                   TREE_CONSTANT (t) = 1;
1308                 }
1309               else
1310                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1311                             gnu_field, NULL_TREE);
1312
1313               elt->index = gnu_field;
1314               elt->value = t;
1315               elt--;
1316             }
1317
1318           gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1319           break;
1320         }
1321
1322       /* ... fall through ... */
1323
1324     case Attr_Access:
1325     case Attr_Unchecked_Access:
1326     case Attr_Code_Address:
1327       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1328       gnu_result
1329         = build_unary_op (((attribute == Attr_Address
1330                             || attribute == Attr_Unrestricted_Access)
1331                            && !Must_Be_Byte_Aligned (gnat_node))
1332                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
1333                           gnu_result_type, gnu_prefix);
1334
1335       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1336          don't try to build a trampoline.  */
1337       if (attribute == Attr_Code_Address)
1338         {
1339           for (gnu_expr = gnu_result;
1340                CONVERT_EXPR_P (gnu_expr);
1341                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1342             TREE_CONSTANT (gnu_expr) = 1;
1343
1344           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1345             TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1346         }
1347
1348       /* For other address attributes applied to a nested function,
1349          find an inner ADDR_EXPR and annotate it so that we can issue
1350          a useful warning with -Wtrampolines.  */
1351       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1352         {
1353           for (gnu_expr = gnu_result;
1354                CONVERT_EXPR_P (gnu_expr);
1355                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1356             ;
1357
1358           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1359               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1360             {
1361               set_expr_location_from_node (gnu_expr, gnat_node);
1362
1363               /* Check that we're not violating the No_Implicit_Dynamic_Code
1364                  restriction.  Be conservative if we don't know anything
1365                  about the trampoline strategy for the target.  */
1366               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1367             }
1368         }
1369       break;
1370
1371     case Attr_Pool_Address:
1372       {
1373         tree gnu_obj_type;
1374         tree gnu_ptr = gnu_prefix;
1375
1376         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1377
1378         /* If this is an unconstrained array, we know the object has been
1379            allocated with the template in front of the object.  So compute
1380            the template address.  */
1381         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1382           gnu_ptr
1383             = convert (build_pointer_type
1384                        (TYPE_OBJECT_RECORD_TYPE
1385                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1386                        gnu_ptr);
1387
1388         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1389         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1390             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1391           {
1392             tree gnu_char_ptr_type
1393               = build_pointer_type (unsigned_char_type_node);
1394             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1395             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1396             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1397                                        gnu_ptr, gnu_pos);
1398           }
1399
1400         gnu_result = convert (gnu_result_type, gnu_ptr);
1401       }
1402       break;
1403
1404     case Attr_Size:
1405     case Attr_Object_Size:
1406     case Attr_Value_Size:
1407     case Attr_Max_Size_In_Storage_Elements:
1408       gnu_expr = gnu_prefix;
1409
1410       /* Remove NOPs and conversions between original and packable version
1411          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1412          to see if a COMPONENT_REF was involved.  */
1413       while (TREE_CODE (gnu_expr) == NOP_EXPR
1414              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1415                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1416                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1417                     == RECORD_TYPE
1418                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1419                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1420         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1421
1422       gnu_prefix = remove_conversions (gnu_prefix, true);
1423       prefix_unused = true;
1424       gnu_type = TREE_TYPE (gnu_prefix);
1425
1426       /* Replace an unconstrained array type with the type of the underlying
1427          array.  We can't do this with a call to maybe_unconstrained_array
1428          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1429          use the record type that will be used to allocate the object and its
1430          template.  */
1431       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1432         {
1433           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1434           if (attribute != Attr_Max_Size_In_Storage_Elements)
1435             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1436         }
1437
1438       /* If we're looking for the size of a field, return the field size.
1439          Otherwise, if the prefix is an object, or if we're looking for
1440          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1441          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1442       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1443         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1444       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1445                || attribute == Attr_Object_Size
1446                || attribute == Attr_Max_Size_In_Storage_Elements)
1447         {
1448           /* If the prefix is an object of a padded type, the GCC size isn't
1449              relevant to the programmer.  Normally what we want is the RM size,
1450              which was set from the specified size, but if it was not set, we
1451              want the size of the field.  Using the MAX of those two produces
1452              the right result in all cases.  Don't use the size of the field
1453              if it's self-referential, since that's never what's wanted.  */
1454           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1455               && TYPE_IS_PADDING_P (gnu_type)
1456               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1457             {
1458               gnu_result = rm_size (gnu_type);
1459               if (!CONTAINS_PLACEHOLDER_P
1460                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1461                 gnu_result
1462                   = size_binop (MAX_EXPR, gnu_result,
1463                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1464             }
1465           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1466             {
1467               Node_Id gnat_deref = Prefix (gnat_node);
1468               Node_Id gnat_actual_subtype
1469                 = Actual_Designated_Subtype (gnat_deref);
1470               tree gnu_ptr_type
1471                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1472
1473               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1474                   && Present (gnat_actual_subtype))
1475                 {
1476                   tree gnu_actual_obj_type
1477                     = gnat_to_gnu_type (gnat_actual_subtype);
1478                   gnu_type
1479                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1480                                                       gnu_actual_obj_type,
1481                                                       get_identifier ("SIZE"),
1482                                                       false);
1483                 }
1484
1485               gnu_result = TYPE_SIZE (gnu_type);
1486             }
1487           else
1488             gnu_result = TYPE_SIZE (gnu_type);
1489         }
1490       else
1491         gnu_result = rm_size (gnu_type);
1492
1493       /* Deal with a self-referential size by returning the maximum size for
1494          a type and by qualifying the size with the object otherwise.  */
1495       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1496         {
1497           if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1498             gnu_result = max_size (gnu_result, true);
1499           else
1500             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1501         }
1502
1503       /* If the type contains a template, subtract its size.  */
1504       if (TREE_CODE (gnu_type) == RECORD_TYPE
1505           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1506         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1507                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1508
1509       /* For 'Max_Size_In_Storage_Elements, adjust the unit.  */
1510       if (attribute == Attr_Max_Size_In_Storage_Elements)
1511         gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1512
1513       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1514       break;
1515
1516     case Attr_Alignment:
1517       {
1518         unsigned int align;
1519
1520         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1521             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1522           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1523
1524         gnu_type = TREE_TYPE (gnu_prefix);
1525         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1526         prefix_unused = true;
1527
1528         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1529           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1530         else
1531           {
1532             Node_Id gnat_prefix = Prefix (gnat_node);
1533             Entity_Id gnat_type = Etype (gnat_prefix);
1534             unsigned int double_align;
1535             bool is_capped_double, align_clause;
1536
1537             /* If the default alignment of "double" or larger scalar types is
1538                specifically capped and there is an alignment clause neither
1539                on the type nor on the prefix itself, return the cap.  */
1540             if ((double_align = double_float_alignment) > 0)
1541               is_capped_double
1542                 = is_double_float_or_array (gnat_type, &align_clause);
1543             else if ((double_align = double_scalar_alignment) > 0)
1544               is_capped_double
1545                 = is_double_scalar_or_array (gnat_type, &align_clause);
1546             else
1547               is_capped_double = align_clause = false;
1548
1549             if (is_capped_double
1550                 && Nkind (gnat_prefix) == N_Identifier
1551                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1552               align_clause = true;
1553
1554             if (is_capped_double && !align_clause)
1555               align = double_align;
1556             else
1557               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1558           }
1559
1560         gnu_result = size_int (align);
1561       }
1562       break;
1563
1564     case Attr_First:
1565     case Attr_Last:
1566     case Attr_Range_Length:
1567       prefix_unused = true;
1568
1569       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1570         {
1571           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1572
1573           if (attribute == Attr_First)
1574             gnu_result = TYPE_MIN_VALUE (gnu_type);
1575           else if (attribute == Attr_Last)
1576             gnu_result = TYPE_MAX_VALUE (gnu_type);
1577           else
1578             gnu_result
1579               = build_binary_op
1580                 (MAX_EXPR, get_base_type (gnu_result_type),
1581                  build_binary_op
1582                  (PLUS_EXPR, get_base_type (gnu_result_type),
1583                   build_binary_op (MINUS_EXPR,
1584                                    get_base_type (gnu_result_type),
1585                                    convert (gnu_result_type,
1586                                             TYPE_MAX_VALUE (gnu_type)),
1587                                    convert (gnu_result_type,
1588                                             TYPE_MIN_VALUE (gnu_type))),
1589                   convert (gnu_result_type, integer_one_node)),
1590                  convert (gnu_result_type, integer_zero_node));
1591
1592           break;
1593         }
1594
1595       /* ... fall through ... */
1596
1597     case Attr_Length:
1598       {
1599         int Dimension = (Present (Expressions (gnat_node))
1600                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1601                          : 1), i;
1602         struct parm_attr_d *pa = NULL;
1603         Entity_Id gnat_param = Empty;
1604
1605         /* Make sure any implicit dereference gets done.  */
1606         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1607         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1608         /* We treat unconstrained array In parameters specially.  */
1609         if (Nkind (Prefix (gnat_node)) == N_Identifier
1610             && !Is_Constrained (Etype (Prefix (gnat_node)))
1611             && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1612           gnat_param = Entity (Prefix (gnat_node));
1613         gnu_type = TREE_TYPE (gnu_prefix);
1614         prefix_unused = true;
1615         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1616
1617         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1618           {
1619             int ndim;
1620             tree gnu_type_temp;
1621
1622             for (ndim = 1, gnu_type_temp = gnu_type;
1623                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1624                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1625                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1626               ;
1627
1628             Dimension = ndim + 1 - Dimension;
1629           }
1630
1631         for (i = 1; i < Dimension; i++)
1632           gnu_type = TREE_TYPE (gnu_type);
1633
1634         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1635
1636         /* When not optimizing, look up the slot associated with the parameter
1637            and the dimension in the cache and create a new one on failure.  */
1638         if (!optimize && Present (gnat_param))
1639           {
1640             FOR_EACH_VEC_ELT (parm_attr, f_parm_attr_cache, i, pa)
1641               if (pa->id == gnat_param && pa->dim == Dimension)
1642                 break;
1643
1644             if (!pa)
1645               {
1646                 pa = ggc_alloc_cleared_parm_attr_d ();
1647                 pa->id = gnat_param;
1648                 pa->dim = Dimension;
1649                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1650               }
1651           }
1652
1653         /* Return the cached expression or build a new one.  */
1654         if (attribute == Attr_First)
1655           {
1656             if (pa && pa->first)
1657               {
1658                 gnu_result = pa->first;
1659                 break;
1660               }
1661
1662             gnu_result
1663               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1664           }
1665
1666         else if (attribute == Attr_Last)
1667           {
1668             if (pa && pa->last)
1669               {
1670                 gnu_result = pa->last;
1671                 break;
1672               }
1673
1674             gnu_result
1675               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1676           }
1677
1678         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1679           {
1680             if (pa && pa->length)
1681               {
1682                 gnu_result = pa->length;
1683                 break;
1684               }
1685             else
1686               {
1687                 /* We used to compute the length as max (hb - lb + 1, 0),
1688                    which could overflow for some cases of empty arrays, e.g.
1689                    when lb == index_type'first.  We now compute the length as
1690                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1691                    much rarer cases, for extremely large arrays we expect
1692                    never to encounter in practice.  In addition, the former
1693                    computation required the use of potentially constraining
1694                    signed arithmetic while the latter doesn't.  Note that
1695                    the comparison must be done in the original index type,
1696                    to avoid any overflow during the conversion.  */
1697                 tree comp_type = get_base_type (gnu_result_type);
1698                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1699                 tree lb = TYPE_MIN_VALUE (index_type);
1700                 tree hb = TYPE_MAX_VALUE (index_type);
1701                 gnu_result
1702                   = build_binary_op (PLUS_EXPR, comp_type,
1703                                      build_binary_op (MINUS_EXPR,
1704                                                       comp_type,
1705                                                       convert (comp_type, hb),
1706                                                       convert (comp_type, lb)),
1707                                      convert (comp_type, integer_one_node));
1708                 gnu_result
1709                   = build_cond_expr (comp_type,
1710                                      build_binary_op (GE_EXPR,
1711                                                       boolean_type_node,
1712                                                       hb, lb),
1713                                      gnu_result,
1714                                      convert (comp_type, integer_zero_node));
1715               }
1716           }
1717
1718         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1719            handling.  Note that these attributes could not have been used on
1720            an unconstrained array type.  */
1721         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1722
1723         /* Cache the expression we have just computed.  Since we want to do it
1724            at run time, we force the use of a SAVE_EXPR and let the gimplifier
1725            create the temporary in the outermost binding level.  We will make
1726            sure in Subprogram_Body_to_gnu that it is evaluated on all possible
1727            paths by forcing its evaluation on entry of the function.  */
1728         if (pa)
1729           {
1730             gnu_result
1731               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1732             if (attribute == Attr_First)
1733               pa->first = gnu_result;
1734             else if (attribute == Attr_Last)
1735               pa->last = gnu_result;
1736             else
1737               pa->length = gnu_result;
1738           }
1739
1740         /* Set the source location onto the predicate of the condition in the
1741            'Length case but do not do it if the expression is cached to avoid
1742            messing up the debug info.  */
1743         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1744                  && TREE_CODE (gnu_result) == COND_EXPR
1745                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1746           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1747                                        gnat_node);
1748
1749         break;
1750       }
1751
1752     case Attr_Bit_Position:
1753     case Attr_Position:
1754     case Attr_First_Bit:
1755     case Attr_Last_Bit:
1756     case Attr_Bit:
1757       {
1758         HOST_WIDE_INT bitsize;
1759         HOST_WIDE_INT bitpos;
1760         tree gnu_offset;
1761         tree gnu_field_bitpos;
1762         tree gnu_field_offset;
1763         tree gnu_inner;
1764         enum machine_mode mode;
1765         int unsignedp, volatilep;
1766
1767         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1768         gnu_prefix = remove_conversions (gnu_prefix, true);
1769         prefix_unused = true;
1770
1771         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1772            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1773         if (attribute == Attr_Bit
1774             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1775             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1776           {
1777             gnu_result = integer_zero_node;
1778             break;
1779           }
1780
1781         else
1782           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1783                       || (attribute == Attr_Bit_Position
1784                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1785
1786         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1787                              &mode, &unsignedp, &volatilep, false);
1788
1789         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1790           {
1791             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1792             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1793
1794             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1795                  TREE_CODE (gnu_inner) == COMPONENT_REF
1796                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1797                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1798               {
1799                 gnu_field_bitpos
1800                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1801                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1802                 gnu_field_offset
1803                   = size_binop (PLUS_EXPR, gnu_field_offset,
1804                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1805               }
1806           }
1807         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1808           {
1809             gnu_field_bitpos = bit_position (gnu_prefix);
1810             gnu_field_offset = byte_position (gnu_prefix);
1811           }
1812         else
1813           {
1814             gnu_field_bitpos = bitsize_zero_node;
1815             gnu_field_offset = size_zero_node;
1816           }
1817
1818         switch (attribute)
1819           {
1820           case Attr_Position:
1821             gnu_result = gnu_field_offset;
1822             break;
1823
1824           case Attr_First_Bit:
1825           case Attr_Bit:
1826             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1827             break;
1828
1829           case Attr_Last_Bit:
1830             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1831             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1832                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1833             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1834                                      bitsize_one_node);
1835             break;
1836
1837           case Attr_Bit_Position:
1838             gnu_result = gnu_field_bitpos;
1839             break;
1840                 }
1841
1842         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1843            handling.  */
1844         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1845         break;
1846       }
1847
1848     case Attr_Min:
1849     case Attr_Max:
1850       {
1851         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1852         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1853
1854         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1855         gnu_result = build_binary_op (attribute == Attr_Min
1856                                       ? MIN_EXPR : MAX_EXPR,
1857                                       gnu_result_type, gnu_lhs, gnu_rhs);
1858       }
1859       break;
1860
1861     case Attr_Passed_By_Reference:
1862       gnu_result = size_int (default_pass_by_ref (gnu_type)
1863                              || must_pass_by_ref (gnu_type));
1864       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1865       break;
1866
1867     case Attr_Component_Size:
1868       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1869           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1870         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1871
1872       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1873       gnu_type = TREE_TYPE (gnu_prefix);
1874
1875       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1876         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1877
1878       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1879              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1880         gnu_type = TREE_TYPE (gnu_type);
1881
1882       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1883
1884       /* Note this size cannot be self-referential.  */
1885       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1886       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1887       prefix_unused = true;
1888       break;
1889
1890     case Attr_Null_Parameter:
1891       /* This is just a zero cast to the pointer type for our prefix and
1892          dereferenced.  */
1893       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1894       gnu_result
1895         = build_unary_op (INDIRECT_REF, NULL_TREE,
1896                           convert (build_pointer_type (gnu_result_type),
1897                                    integer_zero_node));
1898       TREE_PRIVATE (gnu_result) = 1;
1899       break;
1900
1901     case Attr_Mechanism_Code:
1902       {
1903         int code;
1904         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1905
1906         prefix_unused = true;
1907         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1908         if (Present (Expressions (gnat_node)))
1909           {
1910             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1911
1912             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1913                  i--, gnat_obj = Next_Formal (gnat_obj))
1914               ;
1915           }
1916
1917         code = Mechanism (gnat_obj);
1918         if (code == Default)
1919           code = ((present_gnu_tree (gnat_obj)
1920                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1921                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1922                             == PARM_DECL)
1923                            && (DECL_BY_COMPONENT_PTR_P
1924                                (get_gnu_tree (gnat_obj))))))
1925                   ? By_Reference : By_Copy);
1926         gnu_result = convert (gnu_result_type, size_int (- code));
1927       }
1928       break;
1929
1930     default:
1931       /* Say we have an unimplemented attribute.  Then set the value to be
1932          returned to be a zero and hope that's something we can convert to
1933          the type of this attribute.  */
1934       post_error ("unimplemented attribute", gnat_node);
1935       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1936       gnu_result = integer_zero_node;
1937       break;
1938     }
1939
1940   /* If this is an attribute where the prefix was unused, force a use of it if
1941      it has a side-effect.  But don't do it if the prefix is just an entity
1942      name.  However, if an access check is needed, we must do it.  See second
1943      example in AARM 11.6(5.e).  */
1944   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1945       && !Is_Entity_Name (Prefix (gnat_node)))
1946     gnu_result = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix,
1947                                        gnu_result);
1948
1949   *gnu_result_type_p = gnu_result_type;
1950   return gnu_result;
1951 }
1952 \f
1953 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1954    to a GCC tree, which is returned.  */
1955
1956 static tree
1957 Case_Statement_to_gnu (Node_Id gnat_node)
1958 {
1959   tree gnu_result, gnu_expr, gnu_label;
1960   Node_Id gnat_when;
1961   location_t end_locus;
1962   bool may_fallthru = false;
1963
1964   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1965   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1966
1967   /*  The range of values in a case statement is determined by the rules in
1968       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1969       of the expression. One exception arises in the case of a simple name that
1970       is parenthesized. This still has the Etype of the name, but since it is
1971       not a name, para 7 does not apply, and we need to go to the base type.
1972       This is the only case where parenthesization affects the dynamic
1973       semantics (i.e. the range of possible values at run time that is covered
1974       by the others alternative).
1975
1976       Another exception is if the subtype of the expression is non-static.  In
1977       that case, we also have to use the base type.  */
1978   if (Paren_Count (Expression (gnat_node)) != 0
1979       || !Is_OK_Static_Subtype (Underlying_Type
1980                                 (Etype (Expression (gnat_node)))))
1981     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1982
1983   /* We build a SWITCH_EXPR that contains the code with interspersed
1984      CASE_LABEL_EXPRs for each label.  */
1985   if (!Sloc_to_locus (Sloc (gnat_node) + UI_To_Int (End_Span (gnat_node)),
1986       &end_locus))
1987     end_locus = input_location;
1988   gnu_label = create_artificial_label (end_locus);
1989   start_stmt_group ();
1990
1991   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1992        Present (gnat_when);
1993        gnat_when = Next_Non_Pragma (gnat_when))
1994     {
1995       bool choices_added_p = false;
1996       Node_Id gnat_choice;
1997
1998       /* First compile all the different case choices for the current WHEN
1999          alternative.  */
2000       for (gnat_choice = First (Discrete_Choices (gnat_when));
2001            Present (gnat_choice); gnat_choice = Next (gnat_choice))
2002         {
2003           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2004
2005           switch (Nkind (gnat_choice))
2006             {
2007             case N_Range:
2008               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2009               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2010               break;
2011
2012             case N_Subtype_Indication:
2013               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2014                                                 (Constraint (gnat_choice))));
2015               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2016                                                   (Constraint (gnat_choice))));
2017               break;
2018
2019             case N_Identifier:
2020             case N_Expanded_Name:
2021               /* This represents either a subtype range or a static value of
2022                  some kind; Ekind says which.  */
2023               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2024                 {
2025                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2026
2027                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
2028                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
2029                   break;
2030                 }
2031
2032               /* ... fall through ... */
2033
2034             case N_Character_Literal:
2035             case N_Integer_Literal:
2036               gnu_low = gnat_to_gnu (gnat_choice);
2037               break;
2038
2039             case N_Others_Choice:
2040               break;
2041
2042             default:
2043               gcc_unreachable ();
2044             }
2045
2046           /* If the case value is a subtype that raises Constraint_Error at
2047              run time because of a wrong bound, then gnu_low or gnu_high is
2048              not translated into an INTEGER_CST.  In such a case, we need
2049              to ensure that the when statement is not added in the tree,
2050              otherwise it will crash the gimplifier.  */
2051           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2052               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2053             {
2054               add_stmt_with_node (build3
2055                                   (CASE_LABEL_EXPR, void_type_node,
2056                                    gnu_low, gnu_high,
2057                                    create_artificial_label (input_location)),
2058                                   gnat_choice);
2059               choices_added_p = true;
2060             }
2061         }
2062
2063       /* Push a binding level here in case variables are declared as we want
2064          them to be local to this set of statements instead of to the block
2065          containing the Case statement.  */
2066       if (choices_added_p)
2067         {
2068           tree group = build_stmt_group (Statements (gnat_when), true);
2069           bool group_may_fallthru = block_may_fallthru (group);
2070           add_stmt (group);
2071           if (group_may_fallthru)
2072             {
2073               tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2074               SET_EXPR_LOCATION (stmt, end_locus);
2075               add_stmt (stmt);
2076               may_fallthru = true;
2077             }
2078         }
2079     }
2080
2081   /* Now emit a definition of the label the cases branch to, if any.  */
2082   if (may_fallthru)
2083     add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2084   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2085                        end_stmt_group (), NULL_TREE);
2086
2087   return gnu_result;
2088 }
2089 \f
2090 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2091    false, or the maximum value if MAX is true, of TYPE.  */
2092
2093 static bool
2094 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2095 {
2096   tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2097
2098   if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2099     return true;
2100
2101   if (TREE_CODE (val) == NOP_EXPR)
2102     val = (max
2103            ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2104            : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2105
2106   if (TREE_CODE (val) != INTEGER_CST)
2107     return true;
2108
2109   return tree_int_cst_equal (val, min_or_max_val) == 1;
2110 }
2111
2112 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2113    If REVERSE is true, minimum value is taken as maximum value.  */
2114
2115 static inline bool
2116 can_equal_min_val_p (tree val, tree type, bool reverse)
2117 {
2118   return can_equal_min_or_max_val_p (val, type, reverse);
2119 }
2120
2121 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2122    If REVERSE is true, maximum value is taken as minimum value.  */
2123
2124 static inline bool
2125 can_equal_max_val_p (tree val, tree type, bool reverse)
2126 {
2127   return can_equal_min_or_max_val_p (val, type, !reverse);
2128 }
2129
2130 /* Return true if VAL1 can be lower than VAL2.  */
2131
2132 static bool
2133 can_be_lower_p (tree val1, tree val2)
2134 {
2135   if (TREE_CODE (val1) == NOP_EXPR)
2136     val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2137
2138   if (TREE_CODE (val1) != INTEGER_CST)
2139     return true;
2140
2141   if (TREE_CODE (val2) == NOP_EXPR)
2142     val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2143
2144   if (TREE_CODE (val2) != INTEGER_CST)
2145     return true;
2146
2147   return tree_int_cst_lt (val1, val2);
2148 }
2149
2150 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2151    to a GCC tree, which is returned.  */
2152
2153 static tree
2154 Loop_Statement_to_gnu (Node_Id gnat_node)
2155 {
2156   const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2157   tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2158                                NULL_TREE, NULL_TREE, NULL_TREE);
2159   tree gnu_loop_label = create_artificial_label (input_location);
2160   tree gnu_loop_var = NULL_TREE, gnu_cond_expr = NULL_TREE;
2161   tree gnu_result;
2162
2163   /* Set location information for statement and end label.  */
2164   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2165   Sloc_to_locus (Sloc (End_Label (gnat_node)),
2166                  &DECL_SOURCE_LOCATION (gnu_loop_label));
2167   LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2168
2169   /* Save the end label of this LOOP_STMT in a stack so that a corresponding
2170      N_Exit_Statement can find it.  */
2171   VEC_safe_push (tree, gc, gnu_loop_label_stack, gnu_loop_label);
2172
2173   /* Set the condition under which the loop must keep going.
2174      For the case "LOOP .... END LOOP;" the condition is always true.  */
2175   if (No (gnat_iter_scheme))
2176     ;
2177
2178   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2179   else if (Present (Condition (gnat_iter_scheme)))
2180     LOOP_STMT_COND (gnu_loop_stmt)
2181       = gnat_to_gnu (Condition (gnat_iter_scheme));
2182
2183   /* Otherwise we have an iteration scheme and the condition is given by the
2184      bounds of the subtype of the iteration variable.  */
2185   else
2186     {
2187       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2188       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2189       Entity_Id gnat_type = Etype (gnat_loop_var);
2190       tree gnu_type = get_unpadded_type (gnat_type);
2191       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2192       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2193       tree gnu_base_type = get_base_type (gnu_type);
2194       tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2195       tree gnu_first, gnu_last;
2196       enum tree_code update_code, test_code, shift_code;
2197       bool reverse = Reverse_Present (gnat_loop_spec), fallback = false;
2198
2199       /* We must disable modulo reduction for the iteration variable, if any,
2200          in order for the loop comparison to be effective.  */
2201       if (reverse)
2202         {
2203           gnu_first = gnu_high;
2204           gnu_last = gnu_low;
2205           update_code = MINUS_NOMOD_EXPR;
2206           test_code = GE_EXPR;
2207           shift_code = PLUS_NOMOD_EXPR;
2208         }
2209       else
2210         {
2211           gnu_first = gnu_low;
2212           gnu_last = gnu_high;
2213           update_code = PLUS_NOMOD_EXPR;
2214           test_code = LE_EXPR;
2215           shift_code = MINUS_NOMOD_EXPR;
2216         }
2217
2218       /* We use two different strategies to translate the loop, depending on
2219          whether optimization is enabled.
2220
2221          If it is, we try to generate the canonical form of loop expected by
2222          the loop optimizer, which is the do-while form:
2223
2224              ENTRY_COND
2225            loop:
2226              TOP_UPDATE
2227              BODY
2228              BOTTOM_COND
2229              GOTO loop
2230
2231          This makes it possible to bypass loop header copying and to turn the
2232          BOTTOM_COND into an inequality test.  This should catch (almost) all
2233          loops with constant starting point.  If we cannot, we try to generate
2234          the default form, which is:
2235
2236            loop:
2237              TOP_COND
2238              BODY
2239              BOTTOM_UPDATE
2240              GOTO loop
2241
2242          It will be rotated during loop header copying and an entry test added
2243          to yield the do-while form.  This should catch (almost) all loops with
2244          constant ending point.  If we cannot, we generate the fallback form:
2245
2246              ENTRY_COND
2247            loop:
2248              BODY
2249              BOTTOM_COND
2250              BOTTOM_UPDATE
2251              GOTO loop
2252
2253          which works in all cases but for which loop header copying will copy
2254          the BOTTOM_COND, thus adding a third conditional branch.
2255
2256          If optimization is disabled, loop header copying doesn't come into
2257          play and we try to generate the loop forms with the less conditional
2258          branches directly.  First, the default form, it should catch (almost)
2259          all loops with constant ending point.  Then, if we cannot, we try to
2260          generate the shifted form:
2261
2262            loop:
2263              TOP_COND
2264              TOP_UPDATE
2265              BODY
2266              GOTO loop
2267
2268          which should catch loops with constant starting point.  Otherwise, if
2269          we cannot, we generate the fallback form.  */
2270
2271       if (optimize)
2272         {
2273           /* We can use the do-while form if GNU_FIRST-1 doesn't overflow.  */
2274           if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2275             {
2276               gnu_first = build_binary_op (shift_code, gnu_base_type,
2277                                            gnu_first, gnu_one_node);
2278               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2279               LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2280             }
2281
2282           /* Otherwise, we can use the default form if GNU_LAST+1 doesn't.  */
2283           else if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2284             ;
2285
2286           /* Otherwise, use the fallback form.  */
2287           else
2288             fallback = true;
2289         }
2290       else
2291         {
2292           /* We can use the default form if GNU_LAST+1 doesn't overflow.  */
2293           if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2294             ;
2295
2296           /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2297              GNU_LAST-1 does.  */
2298           else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2299                    && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2300             {
2301               gnu_first = build_binary_op (shift_code, gnu_base_type,
2302                                            gnu_first, gnu_one_node);
2303               gnu_last = build_binary_op (shift_code, gnu_base_type,
2304                                           gnu_last, gnu_one_node);
2305               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2306             }
2307
2308           /* Otherwise, use the fallback form.  */
2309           else
2310             fallback = true;
2311         }
2312
2313       if (fallback)
2314         LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2315
2316       /* If we use the BOTTOM_COND, we can turn the test into an inequality
2317          test but we may have to add ENTRY_COND to protect the empty loop.  */
2318       if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2319         {
2320           test_code = NE_EXPR;
2321           if (can_be_lower_p (gnu_high, gnu_low))
2322             {
2323               gnu_cond_expr
2324                 = build3 (COND_EXPR, void_type_node,
2325                           build_binary_op (LE_EXPR, boolean_type_node,
2326                                            gnu_low, gnu_high),
2327                           NULL_TREE, alloc_stmt_list ());
2328               set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2329             }
2330         }
2331
2332       /* Open a new nesting level that will surround the loop to declare the
2333          iteration variable.  */
2334       start_stmt_group ();
2335       gnat_pushlevel ();
2336
2337       /* Declare the iteration variable and set it to its initial value.  */
2338       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2339       if (DECL_BY_REF_P (gnu_loop_var))
2340         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2341
2342       /* Do all the arithmetics in the base type.  */
2343       gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2344
2345       /* Set either the top or bottom exit condition.  */
2346       LOOP_STMT_COND (gnu_loop_stmt)
2347         = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2348                            gnu_last);
2349
2350       /* Set either the top or bottom update statement and give it the source
2351          location of the iteration for better coverage info.  */
2352       LOOP_STMT_UPDATE (gnu_loop_stmt)
2353         = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2354                            build_binary_op (update_code, gnu_base_type,
2355                                             gnu_loop_var, gnu_one_node));
2356       set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
2357                                    gnat_iter_scheme);
2358     }
2359
2360   /* If the loop was named, have the name point to this loop.  In this case,
2361      the association is not a DECL node, but the end label of the loop.  */
2362   if (Present (Identifier (gnat_node)))
2363     save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2364
2365   /* Make the loop body into its own block, so any allocated storage will be
2366      released every iteration.  This is needed for stack allocation.  */
2367   LOOP_STMT_BODY (gnu_loop_stmt)
2368     = build_stmt_group (Statements (gnat_node), true);
2369   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2370
2371   /* If we declared a variable, then we are in a statement group for that
2372      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
2373   if (gnu_loop_var)
2374     {
2375       add_stmt (gnu_loop_stmt);
2376       gnat_poplevel ();
2377       gnu_loop_stmt = end_stmt_group ();
2378     }
2379
2380   /* If we have an outer COND_EXPR, that's our result and this loop is its
2381      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2382   if (gnu_cond_expr)
2383     {
2384       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2385       gnu_result = gnu_cond_expr;
2386       recalculate_side_effects (gnu_cond_expr);
2387     }
2388   else
2389     gnu_result = gnu_loop_stmt;
2390
2391   VEC_pop (tree, gnu_loop_label_stack);
2392
2393   return gnu_result;
2394 }
2395 \f
2396 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2397    handler for the current function.  */
2398
2399 /* This is implemented by issuing a call to the appropriate VMS specific
2400    builtin.  To avoid having VMS specific sections in the global gigi decls
2401    array, we maintain the decls of interest here.  We can't declare them
2402    inside the function because we must mark them never to be GC'd, which we
2403    can only do at the global level.  */
2404
2405 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2406 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2407
2408 static void
2409 establish_gnat_vms_condition_handler (void)
2410 {
2411   tree establish_stmt;
2412
2413   /* Elaborate the required decls on the first call.  Check on the decl for
2414      the gnat condition handler to decide, as this is one we create so we are
2415      sure that it will be non null on subsequent calls.  The builtin decl is
2416      looked up so remains null on targets where it is not implemented yet.  */
2417   if (gnat_vms_condition_handler_decl == NULL_TREE)
2418     {
2419       vms_builtin_establish_handler_decl
2420         = builtin_decl_for
2421           (get_identifier ("__builtin_establish_vms_condition_handler"));
2422
2423       gnat_vms_condition_handler_decl
2424         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2425                                NULL_TREE,
2426                                build_function_type_list (boolean_type_node,
2427                                                          ptr_void_type_node,
2428                                                          ptr_void_type_node,
2429                                                          NULL_TREE),
2430                                NULL_TREE, false, true, true, true, NULL,
2431                                Empty);
2432
2433       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2434       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2435     }
2436
2437   /* Do nothing if the establish builtin is not available, which might happen
2438      on targets where the facility is not implemented.  */
2439   if (vms_builtin_establish_handler_decl == NULL_TREE)
2440     return;
2441
2442   establish_stmt
2443     = build_call_1_expr (vms_builtin_establish_handler_decl,
2444                          build_unary_op
2445                          (ADDR_EXPR, NULL_TREE,
2446                           gnat_vms_condition_handler_decl));
2447
2448   add_stmt (establish_stmt);
2449 }
2450 \f
2451 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
2452    don't return anything.  */
2453
2454 static void
2455 Subprogram_Body_to_gnu (Node_Id gnat_node)
2456 {
2457   /* Defining identifier of a parameter to the subprogram.  */
2458   Entity_Id gnat_param;
2459   /* The defining identifier for the subprogram body. Note that if a
2460      specification has appeared before for this body, then the identifier
2461      occurring in that specification will also be a defining identifier and all
2462      the calls to this subprogram will point to that specification.  */
2463   Entity_Id gnat_subprog_id
2464     = (Present (Corresponding_Spec (gnat_node))
2465        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2466   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
2467   tree gnu_subprog_decl;
2468   /* Its RESULT_DECL node.  */
2469   tree gnu_result_decl;
2470   /* Its FUNCTION_TYPE node.  */
2471   tree gnu_subprog_type;
2472   /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any.  */
2473   tree gnu_cico_list;
2474   /* The entry in the CI_CO_LIST that represents a function return, if any.  */
2475   tree gnu_return_var_elmt = NULL_TREE;
2476   tree gnu_result;
2477   VEC(parm_attr,gc) *cache;
2478
2479   /* If this is a generic object or if it has been eliminated,
2480      ignore it.  */
2481   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2482       || Ekind (gnat_subprog_id) == E_Generic_Function
2483       || Is_Eliminated (gnat_subprog_id))
2484     return;
2485
2486   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
2487      the already-elaborated tree node.  However, if this subprogram had its
2488      elaboration deferred, we will already have made a tree node for it.  So
2489      treat it as not being defined in that case.  Such a subprogram cannot
2490      have an address clause or a freeze node, so this test is safe, though it
2491      does disable some otherwise-useful error checking.  */
2492   gnu_subprog_decl
2493     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2494                           Acts_As_Spec (gnat_node)
2495                           && !present_gnu_tree (gnat_subprog_id));
2496   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
2497   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2498   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2499   if (gnu_cico_list)
2500     gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list);
2501
2502   /* If the function returns by invisible reference, make it explicit in the
2503      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.
2504      Handle the explicit case here and the copy-in/copy-out case below.  */
2505   if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt)
2506     {
2507       TREE_TYPE (gnu_result_decl)
2508         = build_reference_type (TREE_TYPE (gnu_result_decl));
2509       relayout_decl (gnu_result_decl);
2510     }
2511
2512   /* Set the line number in the decl to correspond to that of the body so that
2513      the line number notes are written correctly.  */
2514   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
2515
2516   /* Initialize the information structure for the function.  */
2517   allocate_struct_function (gnu_subprog_decl, false);
2518   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
2519     = ggc_alloc_cleared_language_function ();
2520   set_cfun (NULL);
2521
2522   begin_subprog_body (gnu_subprog_decl);
2523
2524   /* If there are In Out or Out parameters, we need to ensure that the return
2525      statement properly copies them out.  We do this by making a new block and
2526      converting any return into a goto to a label at the end of the block.  */
2527   if (gnu_cico_list)
2528     {
2529       tree gnu_return_var = NULL_TREE;
2530
2531       VEC_safe_push (tree, gc, gnu_return_label_stack,
2532                      create_artificial_label (input_location));
2533
2534       start_stmt_group ();
2535       gnat_pushlevel ();
2536
2537       /* If this is a function with In Out or Out parameters, we also need a
2538          variable for the return value to be placed.  */
2539       if (gnu_return_var_elmt)
2540         {
2541           tree gnu_return_type
2542             = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
2543
2544           /* If the function returns by invisible reference, make it
2545              explicit in the function body.  See gnat_to_gnu_entity,
2546              E_Subprogram_Type case.  */
2547           if (TREE_ADDRESSABLE (gnu_subprog_type))
2548             gnu_return_type = build_reference_type (gnu_return_type);
2549
2550           gnu_return_var
2551             = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
2552                                gnu_return_type, NULL_TREE, false, false,
2553                                false, false, NULL, gnat_subprog_id);
2554           TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
2555         }
2556
2557       VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var);
2558
2559       /* See whether there are parameters for which we don't have a GCC tree
2560          yet.  These must be Out parameters.  Make a VAR_DECL for them and
2561          put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
2562          We can match up the entries because TYPE_CI_CO_LIST is in the order
2563          of the parameters.  */
2564       for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2565            Present (gnat_param);
2566            gnat_param = Next_Formal_With_Extras (gnat_param))
2567         if (!present_gnu_tree (gnat_param))
2568           {
2569             tree gnu_cico_entry = gnu_cico_list;
2570
2571             /* Skip any entries that have been already filled in; they must
2572                correspond to In Out parameters.  */
2573             while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
2574               gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
2575
2576             /* Do any needed references for padded types.  */
2577             TREE_VALUE (gnu_cico_entry)
2578               = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)),
2579                          gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2580           }
2581     }
2582   else
2583     VEC_safe_push (tree, gc, gnu_return_label_stack, NULL_TREE);
2584
2585   /* Get a tree corresponding to the code for the subprogram.  */
2586   start_stmt_group ();
2587   gnat_pushlevel ();
2588
2589   /* On VMS, establish our condition handler to possibly turn a condition into
2590      the corresponding exception if the subprogram has a foreign convention or
2591      is exported.
2592
2593      To ensure proper execution of local finalizations on condition instances,
2594      we must turn a condition into the corresponding exception even if there
2595      is no applicable Ada handler, and need at least one condition handler per
2596      possible call chain involving GNAT code.  OTOH, establishing the handler
2597      has a cost so we want to minimize the number of subprograms into which
2598      this happens.  The foreign or exported condition is expected to satisfy
2599      all the constraints.  */
2600   if (TARGET_ABI_OPEN_VMS
2601       && (Has_Foreign_Convention (gnat_subprog_id)
2602           || Is_Exported (gnat_subprog_id)))
2603     establish_gnat_vms_condition_handler ();
2604
2605   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
2606
2607   /* Generate the code of the subprogram itself.  A return statement will be
2608      present and any Out parameters will be handled there.  */
2609   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
2610   gnat_poplevel ();
2611   gnu_result = end_stmt_group ();
2612
2613   /* If we populated the parameter attributes cache, we need to make sure that
2614      the cached expressions are evaluated on all the possible paths leading to
2615      their uses.  So we force their evaluation on entry of the function.  */
2616   cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
2617   if (cache)
2618     {
2619       struct parm_attr_d *pa;
2620       int i;
2621
2622       start_stmt_group ();
2623
2624       FOR_EACH_VEC_ELT (parm_attr, cache, i, pa)
2625         {
2626           if (pa->first)
2627             add_stmt_with_node_force (pa->first, gnat_node);
2628           if (pa->last)
2629             add_stmt_with_node_force (pa->last, gnat_node);
2630           if (pa->length)
2631             add_stmt_with_node_force (pa->length, gnat_node);
2632         }
2633
2634       add_stmt (gnu_result);
2635       gnu_result = end_stmt_group ();
2636     }
2637
2638   /* If we are dealing with a return from an Ada procedure with parameters
2639      passed by copy-in/copy-out, we need to return a record containing the
2640      final values of these parameters.  If the list contains only one entry,
2641      return just that entry though.
2642
2643      For a full description of the copy-in/copy-out parameter mechanism, see
2644      the part of the gnat_to_gnu_entity routine dealing with the translation
2645      of subprograms.
2646
2647      We need to make a block that contains the definition of that label and
2648      the copying of the return value.  It first contains the function, then
2649      the label and copy statement.  */
2650   if (gnu_cico_list)
2651     {
2652       tree gnu_retval;
2653
2654       add_stmt (gnu_result);
2655       add_stmt (build1 (LABEL_EXPR, void_type_node,
2656                         VEC_last (tree, gnu_return_label_stack)));
2657
2658       if (list_length (gnu_cico_list) == 1)
2659         gnu_retval = TREE_VALUE (gnu_cico_list);
2660       else
2661         gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
2662                                                   gnu_cico_list);
2663
2664       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
2665                           End_Label (Handled_Statement_Sequence (gnat_node)));
2666       gnat_poplevel ();
2667       gnu_result = end_stmt_group ();
2668     }
2669
2670   VEC_pop (tree, gnu_return_label_stack);
2671
2672   end_subprog_body (gnu_result);
2673
2674   /* Attempt setting the end_locus of our GCC body tree, typically a
2675      BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
2676      declaration tree.  */
2677   set_end_locus_from_node (gnu_result, gnat_node);
2678   set_end_locus_from_node (gnu_subprog_decl, gnat_node);
2679
2680   /* Finally annotate the parameters and disconnect the trees for parameters
2681      that we have turned into variables since they are now unusable.  */
2682   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2683        Present (gnat_param);
2684        gnat_param = Next_Formal_With_Extras (gnat_param))
2685     {
2686       tree gnu_param = get_gnu_tree (gnat_param);
2687       bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
2688
2689       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
2690                        DECL_BY_REF_P (gnu_param),
2691                        !is_var_decl && DECL_BY_DOUBLE_REF_P (gnu_param));
2692
2693       if (is_var_decl)
2694         save_gnu_tree (gnat_param, NULL_TREE, false);
2695     }
2696
2697   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2698     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2699
2700   if (gnu_return_var_elmt)
2701     TREE_VALUE (gnu_return_var_elmt) = void_type_node;
2702
2703   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2704 }
2705 \f
2706 /* Create a temporary variable with PREFIX and TYPE, and return it.  */
2707
2708 static tree
2709 create_temporary (const char *prefix, tree type)
2710 {
2711   tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
2712                                    type, NULL_TREE, false, false, false, false,
2713                                    NULL, Empty);
2714   DECL_ARTIFICIAL (gnu_temp) = 1;
2715   DECL_IGNORED_P (gnu_temp) = 1;
2716
2717   return gnu_temp;
2718 }
2719
2720 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
2721    Put the initialization statement into GNU_INIT_STMT and annotate it with
2722    the SLOC of GNAT_NODE.  Return the temporary variable.  */
2723
2724 static tree
2725 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
2726                        Node_Id gnat_node)
2727 {
2728   tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
2729
2730   *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
2731   set_expr_location_from_node (*gnu_init_stmt, gnat_node);
2732
2733   return gnu_temp;
2734 }
2735
2736 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2737    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2738    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2739    If GNU_TARGET is non-null, this must be a function call on the RHS of a
2740    N_Assignment_Statement and the result is to be placed into that object.  */
2741
2742 static tree
2743 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2744 {
2745   const bool function_call = (Nkind (gnat_node) == N_Function_Call);
2746   const bool returning_value = (function_call && !gnu_target);
2747   /* The GCC node corresponding to the GNAT subprogram name.  This can either
2748      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2749      or an indirect reference expression (an INDIRECT_REF node) pointing to a
2750      subprogram.  */
2751   tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
2752   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2753   tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
2754   /* The return type of the FUNCTION_TYPE.  */
2755   tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
2756   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
2757   VEC(tree,gc) *gnu_actual_vec = NULL;
2758   tree gnu_name_list = NULL_TREE;
2759   tree gnu_stmt_list = NULL_TREE;
2760   tree gnu_after_list = NULL_TREE;
2761   tree gnu_retval = NULL_TREE;
2762   tree gnu_call, gnu_result;
2763   bool went_into_elab_proc = false;
2764   bool pushed_binding_level = false;
2765   Entity_Id gnat_formal;
2766   Node_Id gnat_actual;
2767
2768   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2769
2770   /* If we are calling a stubbed function, raise Program_Error, but Elaborate
2771      all our args first.  */
2772   if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
2773     {
2774       tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
2775                                          gnat_node, N_Raise_Program_Error);
2776
2777       for (gnat_actual = First_Actual (gnat_node);
2778            Present (gnat_actual);
2779            gnat_actual = Next_Actual (gnat_actual))
2780         add_stmt (gnat_to_gnu (gnat_actual));
2781
2782       if (returning_value)
2783         {
2784           *gnu_result_type_p = gnu_result_type;
2785           return build1 (NULL_EXPR, gnu_result_type, call_expr);
2786         }
2787
2788       return call_expr;
2789     }
2790
2791   /* The only way we can be making a call via an access type is if Name is an
2792      explicit dereference.  In that case, get the list of formal args from the
2793      type the access type is pointing to.  Otherwise, get the formals from the
2794      entity being called.  */
2795   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2796     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2797   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2798     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2799     gnat_formal = Empty;
2800   else
2801     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2802
2803   /* The lifetime of the temporaries created for the call ends right after the
2804      return value is copied, so we can give them the scope of the elaboration
2805      routine at top level.  */
2806   if (!current_function_decl)
2807     {
2808       current_function_decl = get_elaboration_procedure ();
2809       went_into_elab_proc = true;
2810     }
2811
2812   /* First, create the temporary for the return value if we need it: for a
2813      variable-sized return type if there is no target or if this is slice,
2814      because the gimplifier doesn't support these cases; or for a function
2815      with copy-in/copy-out parameters if there is no target, because we'll
2816      need to preserve the return value before copying back the parameters.
2817      This must be done before we push a new binding level around the call
2818      as we will pop it before copying the return value.  */
2819   if (function_call
2820       && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
2821            && (!gnu_target || TREE_CODE (gnu_target) == ARRAY_RANGE_REF))
2822           || (!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))))
2823     gnu_retval = create_temporary ("R", gnu_result_type);
2824
2825   /* Create the list of the actual parameters as GCC expects it, namely a
2826      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
2827      is an expression and the TREE_PURPOSE field is null.  But skip Out
2828      parameters not passed by reference and that need not be copied in.  */
2829   for (gnat_actual = First_Actual (gnat_node);
2830        Present (gnat_actual);
2831        gnat_formal = Next_Formal_With_Extras (gnat_formal),
2832        gnat_actual = Next_Actual (gnat_actual))
2833     {
2834       tree gnu_formal = present_gnu_tree (gnat_formal)
2835                         ? get_gnu_tree (gnat_formal) : NULL_TREE;
2836       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2837       /* In the Out or In Out case, we must suppress conversions that yield
2838          an lvalue but can nevertheless cause the creation of a temporary,
2839          because we need the real object in this case, either to pass its
2840          address if it's passed by reference or as target of the back copy
2841          done after the call if it uses the copy-in/copy-out mechanism.
2842          We do it in the In case too, except for an unchecked conversion
2843          because it alone can cause the actual to be misaligned and the
2844          addressability test is applied to the real object.  */
2845       bool suppress_type_conversion
2846         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2847             && Ekind (gnat_formal) != E_In_Parameter)
2848            || (Nkind (gnat_actual) == N_Type_Conversion
2849                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2850       Node_Id gnat_name = suppress_type_conversion
2851                           ? Expression (gnat_actual) : gnat_actual;
2852       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2853       tree gnu_actual;
2854
2855       /* If it's possible we may need to use this expression twice, make sure
2856          that any side-effects are handled via SAVE_EXPRs; likewise if we need
2857          to force side-effects before the call.
2858          ??? This is more conservative than we need since we don't need to do
2859          this for pass-by-ref with no conversion.  */
2860       if (Ekind (gnat_formal) != E_In_Parameter)
2861         gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
2862
2863       /* If we are passing a non-addressable parameter by reference, pass the
2864          address of a copy.  In the Out or In Out case, set up to copy back
2865          out after the call.  */
2866       if (gnu_formal
2867           && (DECL_BY_REF_P (gnu_formal)
2868               || (TREE_CODE (gnu_formal) == PARM_DECL
2869                   && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2870                       || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2871           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2872           && !addressable_p (gnu_name, gnu_name_type))
2873         {
2874           bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
2875           tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
2876
2877           /* Do not issue warnings for CONSTRUCTORs since this is not a copy
2878              but sort of an instantiation for them.  */
2879           if (TREE_CODE (gnu_name) == CONSTRUCTOR)
2880             ;
2881
2882           /* If the type is passed by reference, a copy is not allowed.  */
2883           else if (TREE_ADDRESSABLE (gnu_formal_type))
2884             post_error ("misaligned actual cannot be passed by reference",
2885                         gnat_actual);
2886
2887           /* For users of Starlet we issue a warning because the interface
2888              apparently assumes that by-ref parameters outlive the procedure
2889              invocation.  The code still will not work as intended, but we
2890              cannot do much better since low-level parts of the back-end
2891              would allocate temporaries at will because of the misalignment
2892              if we did not do so here.  */
2893           else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2894             {
2895               post_error
2896                 ("?possible violation of implicit assumption", gnat_actual);
2897               post_error_ne
2898                 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
2899                  Entity (Name (gnat_node)));
2900               post_error_ne ("?because of misalignment of &", gnat_actual,
2901                              gnat_formal);
2902             }
2903
2904           /* If the actual type of the object is already the nominal type,
2905              we have nothing to do, except if the size is self-referential
2906              in which case we'll remove the unpadding below.  */
2907           if (TREE_TYPE (gnu_name) == gnu_name_type
2908               && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
2909             ;
2910
2911           /* Otherwise remove the unpadding from all the objects.  */
2912           else if (TREE_CODE (gnu_name) == COMPONENT_REF
2913                    && TYPE_IS_PADDING_P
2914                       (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
2915             gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
2916
2917           /* Otherwise convert to the nominal type of the object if needed.
2918              There are several cases in which we need to make the temporary
2919              using this type instead of the actual type of the object when
2920              they are distinct, because the expectations of the callee would
2921              otherwise not be met:
2922                - if it's a justified modular type,
2923                - if the actual type is a smaller form of it,
2924                - if it's a smaller form of the actual type.  */
2925           else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
2926                     && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
2927                         || smaller_form_type_p (TREE_TYPE (gnu_name),
2928                                                 gnu_name_type)))
2929                    || (INTEGRAL_TYPE_P (gnu_name_type)
2930                        && smaller_form_type_p (gnu_name_type,
2931                                                TREE_TYPE (gnu_name))))
2932             gnu_name = convert (gnu_name_type, gnu_name);
2933
2934           /* If this is an In Out or Out parameter and we're returning a value,
2935              we need to create a temporary for the return value because we must
2936              preserve it before copying back at the very end.  */
2937           if (!in_param && returning_value && !gnu_retval)
2938             gnu_retval = create_temporary ("R", gnu_result_type);
2939
2940           /* If we haven't pushed a binding level, push a new one.  This will
2941              narrow the lifetime of the temporary we are about to make as much
2942              as possible.  The drawback is that we'd need to create a temporary
2943              for the return value, if any (see comment before the loop).  So do
2944              it only when this temporary was already created just above.  */
2945           if (!pushed_binding_level && !(in_param && returning_value))
2946             {
2947               start_stmt_group ();
2948               gnat_pushlevel ();
2949               pushed_binding_level = true;
2950             }
2951
2952           /* Create an explicit temporary holding the copy.  */
2953           gnu_temp
2954             = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
2955
2956           /* But initialize it on the fly like for an implicit temporary as
2957              we aren't necessarily having a statement list.  */
2958           gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
2959                                           gnu_temp);
2960
2961           /* Set up to move the copy back to the original if needed.  */
2962           if (!in_param)
2963             {
2964               gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
2965                                           gnu_temp);
2966               set_expr_location_from_node (gnu_stmt, gnat_node);
2967               append_to_statement_list (gnu_stmt, &gnu_after_list);
2968             }
2969         }
2970
2971       /* Start from the real object and build the actual.  */
2972       gnu_actual = gnu_name;
2973
2974       /* If this was a procedure call, we may not have removed any padding.
2975          So do it here for the part we will use as an input, if any.  */
2976       if (Ekind (gnat_formal) != E_Out_Parameter
2977           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2978         gnu_actual
2979           = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
2980
2981       /* Put back the conversion we suppressed above in the computation of the
2982          real object.  And even if we didn't suppress any conversion there, we
2983          may have suppressed a conversion to the Etype of the actual earlier,
2984          since the parent is a procedure call, so put it back here.  */
2985       if (suppress_type_conversion
2986           && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2987         gnu_actual
2988           = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2989                                gnu_actual, No_Truncation (gnat_actual));
2990       else
2991         gnu_actual
2992           = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
2993
2994       /* Make sure that the actual is in range of the formal's type.  */
2995       if (Ekind (gnat_formal) != E_Out_Parameter
2996           && Do_Range_Check (gnat_actual))
2997         gnu_actual
2998           = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
2999
3000       /* Unless this is an In parameter, we must remove any justified modular
3001          building from GNU_NAME to get an lvalue.  */
3002       if (Ekind (gnat_formal) != E_In_Parameter
3003           && TREE_CODE (gnu_name) == CONSTRUCTOR
3004           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
3005           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
3006         gnu_name
3007           = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
3008
3009       /* If we have not saved a GCC object for the formal, it means it is an
3010          Out parameter not passed by reference and that need not be copied in.
3011          Otherwise, first see if the parameter is passed by reference.  */
3012       if (gnu_formal
3013           && TREE_CODE (gnu_formal) == PARM_DECL
3014           && DECL_BY_REF_P (gnu_formal))
3015         {
3016           if (Ekind (gnat_formal) != E_In_Parameter)
3017             {
3018               /* In Out or Out parameters passed by reference don't use the
3019                  copy-in/copy-out mechanism so the address of the real object
3020                  must be passed to the function.  */
3021               gnu_actual = gnu_name;
3022
3023               /* If we have a padded type, be sure we've removed padding.  */
3024               if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
3025                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
3026                                       gnu_actual);
3027
3028               /* If we have the constructed subtype of an aliased object
3029                  with an unconstrained nominal subtype, the type of the
3030                  actual includes the template, although it is formally
3031                  constrained.  So we need to convert it back to the real
3032                  constructed subtype to retrieve the constrained part
3033                  and takes its address.  */
3034               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
3035                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
3036                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
3037                   && Is_Array_Type (Etype (gnat_actual)))
3038                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
3039                                       gnu_actual);
3040             }
3041
3042           /* There is no need to convert the actual to the formal's type before
3043              taking its address.  The only exception is for unconstrained array
3044              types because of the way we build fat pointers.  */
3045           else if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
3046             gnu_actual = convert (gnu_formal_type, gnu_actual);
3047
3048           /* The symmetry of the paths to the type of an entity is broken here
3049              since arguments don't know that they will be passed by ref.  */
3050           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3051
3052           if (DECL_BY_DOUBLE_REF_P (gnu_formal))
3053             gnu_actual
3054               = build_unary_op (ADDR_EXPR, TREE_TYPE (gnu_formal_type),
3055                                 gnu_actual);
3056
3057           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
3058         }
3059       else if (gnu_formal
3060                && TREE_CODE (gnu_formal) == PARM_DECL
3061                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
3062         {
3063           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3064           gnu_actual = maybe_implicit_deref (gnu_actual);
3065           gnu_actual = maybe_unconstrained_array (gnu_actual);
3066
3067           if (TYPE_IS_PADDING_P (gnu_formal_type))
3068             {
3069               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
3070               gnu_actual = convert (gnu_formal_type, gnu_actual);
3071             }
3072
3073           /* Take the address of the object and convert to the proper pointer
3074              type.  We'd like to actually compute the address of the beginning
3075              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
3076              possibility that the ARRAY_REF might return a constant and we'd be
3077              getting the wrong address.  Neither approach is exactly correct,
3078              but this is the most likely to work in all cases.  */
3079           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
3080         }
3081       else if (gnu_formal
3082                && TREE_CODE (gnu_formal) == PARM_DECL
3083                && DECL_BY_DESCRIPTOR_P (gnu_formal))
3084         {
3085           gnu_actual = convert (gnu_formal_type, gnu_actual);
3086
3087           /* If this is 'Null_Parameter, pass a zero descriptor.  */
3088           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
3089                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
3090               && TREE_PRIVATE (gnu_actual))
3091             gnu_actual
3092               = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
3093           else
3094             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
3095                                          fill_vms_descriptor
3096                                          (TREE_TYPE (TREE_TYPE (gnu_formal)),
3097                                           gnu_actual, gnat_actual));
3098         }
3099       else
3100         {
3101           tree gnu_size;
3102
3103           if (Ekind (gnat_formal) != E_In_Parameter)
3104             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
3105
3106           if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
3107             {
3108               /* Make sure side-effects are evaluated before the call.  */
3109               if (TREE_SIDE_EFFECTS (gnu_name))
3110                 append_to_statement_list (gnu_name, &gnu_stmt_list);
3111               continue;
3112             }
3113
3114           gnu_actual = convert (gnu_formal_type, gnu_actual);
3115
3116           /* If this is 'Null_Parameter, pass a zero even though we are
3117              dereferencing it.  */
3118           if (TREE_CODE (gnu_actual) == INDIRECT_REF
3119               && TREE_PRIVATE (gnu_actual)
3120               && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
3121               && TREE_CODE (gnu_size) == INTEGER_CST
3122               && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
3123             gnu_actual
3124               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
3125                                    convert (gnat_type_for_size
3126                                             (TREE_INT_CST_LOW (gnu_size), 1),
3127                                             integer_zero_node),
3128                                    false);
3129           else
3130             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
3131         }
3132
3133       VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual);
3134     }
3135
3136   gnu_call
3137     = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
3138   set_expr_location_from_node (gnu_call, gnat_node);
3139
3140   /* If we have created a temporary for the return value, initialize it.  */
3141   if (gnu_retval)
3142     {
3143       tree gnu_stmt
3144         = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
3145       set_expr_location_from_node (gnu_stmt, gnat_node);
3146       append_to_statement_list (gnu_stmt, &gnu_stmt_list);
3147       gnu_call = gnu_retval;
3148     }
3149
3150   /* If this is a subprogram with copy-in/copy-out parameters, we need to
3151      unpack the valued returned from the function into the In Out or Out
3152      parameters.  We deal with the function return (if this is an Ada
3153      function) below.  */
3154   if (TYPE_CI_CO_LIST (gnu_subprog_type))
3155     {
3156       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
3157          copy-out parameters.  */
3158       tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3159       const int length = list_length (gnu_cico_list);
3160
3161       /* The call sequence must contain one and only one call, even though the
3162          function is pure.  Save the result into a temporary if needed.  */
3163       if (length > 1)
3164         {
3165           if (!gnu_retval)
3166             {
3167               tree gnu_stmt;
3168               /* If we haven't pushed a binding level, push a new one.  This
3169                  will narrow the lifetime of the temporary we are about to
3170                  make as much as possible.  */
3171               if (!pushed_binding_level)
3172                 {
3173                   start_stmt_group ();
3174                   gnat_pushlevel ();
3175                   pushed_binding_level = true;
3176                 }
3177               gnu_call
3178                 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
3179               append_to_statement_list (gnu_stmt, &gnu_stmt_list);
3180             }
3181
3182           gnu_name_list = nreverse (gnu_name_list);
3183         }
3184
3185       /* The first entry is for the actual return value if this is a
3186          function, so skip it.  */
3187       if (TREE_VALUE (gnu_cico_list) == void_type_node)
3188         gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3189
3190       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3191         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
3192       else
3193         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
3194
3195       for (gnat_actual = First_Actual (gnat_node);
3196            Present (gnat_actual);
3197            gnat_formal = Next_Formal_With_Extras (gnat_formal),
3198            gnat_actual = Next_Actual (gnat_actual))
3199         /* If we are dealing with a copy-in/copy-out parameter, we must
3200            retrieve its value from the record returned in the call.  */
3201         if (!(present_gnu_tree (gnat_formal)
3202               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3203               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
3204                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3205                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
3206                            || (DECL_BY_DESCRIPTOR_P
3207                                (get_gnu_tree (gnat_formal))))))))
3208             && Ekind (gnat_formal) != E_In_Parameter)
3209           {
3210             /* Get the value to assign to this Out or In Out parameter.  It is
3211                either the result of the function if there is only a single such
3212                parameter or the appropriate field from the record returned.  */
3213             tree gnu_result
3214               = length == 1
3215                 ? gnu_call
3216                 : build_component_ref (gnu_call, NULL_TREE,
3217                                        TREE_PURPOSE (gnu_cico_list), false);
3218
3219             /* If the actual is a conversion, get the inner expression, which
3220                will be the real destination, and convert the result to the
3221                type of the actual parameter.  */
3222             tree gnu_actual
3223               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3224
3225             /* If the result is a padded type, remove the padding.  */
3226             if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3227               gnu_result
3228                 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
3229                            gnu_result);
3230
3231             /* If the actual is a type conversion, the real target object is
3232                denoted by the inner Expression and we need to convert the
3233                result to the associated type.
3234                We also need to convert our gnu assignment target to this type
3235                if the corresponding GNU_NAME was constructed from the GNAT
3236                conversion node and not from the inner Expression.  */
3237             if (Nkind (gnat_actual) == N_Type_Conversion)
3238               {
3239                 gnu_result
3240                   = convert_with_check
3241                     (Etype (Expression (gnat_actual)), gnu_result,
3242                      Do_Overflow_Check (gnat_actual),
3243                      Do_Range_Check (Expression (gnat_actual)),
3244                      Float_Truncate (gnat_actual), gnat_actual);
3245
3246                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
3247                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
3248               }
3249
3250             /* Unchecked conversions as actuals for Out parameters are not
3251                allowed in user code because they are not variables, but do
3252                occur in front-end expansions.  The associated GNU_NAME is
3253                always obtained from the inner expression in such cases.  */
3254             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
3255               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
3256                                               gnu_result,
3257                                               No_Truncation (gnat_actual));
3258             else
3259               {
3260                 if (Do_Range_Check (gnat_actual))
3261                   gnu_result
3262                     = emit_range_check (gnu_result, Etype (gnat_actual),
3263                                         gnat_actual);
3264
3265                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
3266                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
3267                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
3268               }
3269
3270             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3271                                           gnu_actual, gnu_result);
3272             set_expr_location_from_node (gnu_result, gnat_node);
3273             append_to_statement_list (gnu_result, &gnu_stmt_list);
3274             gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3275             gnu_name_list = TREE_CHAIN (gnu_name_list);
3276           }
3277     }
3278
3279   /* If this is a function call, the result is the call expression unless a
3280      target is specified, in which case we copy the result into the target
3281      and return the assignment statement.  */
3282   if (function_call)
3283     {
3284       /* If this is a function with copy-in/copy-out parameters, extract the
3285          return value from it and update the return type.  */
3286       if (TYPE_CI_CO_LIST (gnu_subprog_type))
3287         {
3288           tree gnu_elmt = value_member (void_type_node,
3289                                         TYPE_CI_CO_LIST (gnu_subprog_type));
3290           gnu_call = build_component_ref (gnu_call, NULL_TREE,
3291                                           TREE_PURPOSE (gnu_elmt), false);
3292           gnu_result_type = TREE_TYPE (gnu_call);
3293         }
3294
3295       /* If the function returns an unconstrained array or by direct reference,
3296          we have to dereference the pointer.  */
3297       if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
3298           || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
3299         gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
3300
3301       if (gnu_target)
3302         {
3303           Node_Id gnat_parent = Parent (gnat_node);
3304           enum tree_code op_code;
3305
3306           /* If range check is needed, emit code to generate it.  */
3307           if (Do_Range_Check (gnat_node))
3308             gnu_call
3309               = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
3310                                   gnat_parent);
3311
3312           /* ??? If the return type has variable size, then force the return
3313              slot optimization as we would not be able to create a temporary.
3314              Likewise if it was unconstrained as we would copy too much data.
3315              That's what has been done historically.  */
3316           if (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
3317               || (TYPE_IS_PADDING_P (gnu_result_type)
3318                   && CONTAINS_PLACEHOLDER_P
3319                      (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type))))))
3320             op_code = INIT_EXPR;
3321           else
3322             op_code = MODIFY_EXPR;
3323
3324           gnu_call
3325             = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
3326           set_expr_location_from_node (gnu_call, gnat_parent);
3327           append_to_statement_list (gnu_call, &gnu_stmt_list);
3328         }
3329       else
3330         *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
3331     }
3332
3333   /* Otherwise, if this is a procedure call statement without copy-in/copy-out
3334      parameters, the result is just the call statement.  */
3335   else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
3336     append_to_statement_list (gnu_call, &gnu_stmt_list);
3337
3338   /* Finally, add the copy back statements, if any.  */
3339   append_to_statement_list (gnu_after_list, &gnu_stmt_list);
3340
3341   if (went_into_elab_proc)
3342     current_function_decl = NULL_TREE;
3343
3344   /* If we have pushed a binding level, pop it and finish up the enclosing
3345      statement group.  */
3346   if (pushed_binding_level)
3347     {
3348       add_stmt (gnu_stmt_list);
3349       gnat_poplevel ();
3350       gnu_result = end_stmt_group ();
3351     }
3352
3353   /* Otherwise, retrieve the statement list, if any.  */
3354   else if (gnu_stmt_list)
3355     gnu_result = gnu_stmt_list;
3356
3357   /* Otherwise, just return the call expression.  */
3358   else
3359     return gnu_call;
3360
3361   /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.  */
3362   if (returning_value)
3363     gnu_result
3364       = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
3365
3366   return gnu_result;
3367 }
3368 \f
3369 /* Subroutine of gnat_to_gnu to translate gnat_node, an
3370    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
3371
3372 static tree
3373 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
3374 {
3375   tree gnu_jmpsave_decl = NULL_TREE;
3376   tree gnu_jmpbuf_decl = NULL_TREE;
3377   /* If just annotating, ignore all EH and cleanups.  */
3378   bool gcc_zcx = (!type_annotate_only
3379                   && Present (Exception_Handlers (gnat_node))
3380                   && Exception_Mechanism == Back_End_Exceptions);
3381   bool setjmp_longjmp
3382     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
3383        && Exception_Mechanism == Setjmp_Longjmp);
3384   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
3385   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
3386   tree gnu_inner_block; /* The statement(s) for the block itself.  */
3387   tree gnu_result;
3388   tree gnu_expr;
3389   Node_Id gnat_temp;
3390
3391   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
3392      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
3393      add_cleanup, and when we leave the binding, end_stmt_group will create
3394      the TRY_FINALLY_EXPR.
3395
3396      ??? The region level calls down there have been specifically put in place
3397      for a ZCX context and currently the order in which things are emitted
3398      (region/handlers) is different from the SJLJ case. Instead of putting
3399      other calls with different conditions at other places for the SJLJ case,
3400      it seems cleaner to reorder things for the SJLJ case and generalize the
3401      condition to make it not ZCX specific.
3402
3403      If there are any exceptions or cleanup processing involved, we need an
3404      outer statement group (for Setjmp_Longjmp) and binding level.  */
3405   if (binding_for_block)
3406     {
3407       start_stmt_group ();
3408       gnat_pushlevel ();
3409     }
3410
3411   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
3412      area for address of previous buffer.  Do this first since we need to have
3413      the setjmp buf known for any decls in this block.  */
3414   if (setjmp_longjmp)
3415     {
3416       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
3417                                           NULL_TREE, jmpbuf_ptr_type,
3418                                           build_call_0_expr (get_jmpbuf_decl),
3419                                           false, false, false, false,
3420                                           NULL, gnat_node);
3421       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
3422
3423       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
3424          because of the unstructured form of EH used by setjmp_longjmp, there
3425          might be forward edges going to __builtin_setjmp receivers on which
3426          it is uninitialized, although they will never be actually taken.  */
3427       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
3428       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
3429                                          NULL_TREE, jmpbuf_type, NULL_TREE,
3430                                          false, false, false, false,
3431                                          NULL, gnat_node);
3432       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
3433
3434       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
3435
3436       /* When we exit this block, restore the saved value.  */
3437       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
3438                    End_Label (gnat_node));
3439     }
3440
3441   /* If we are to call a function when exiting this block, add a cleanup
3442      to the binding level we made above.  Note that add_cleanup is FIFO
3443      so we must register this cleanup after the EH cleanup just above.  */
3444   if (at_end)
3445     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
3446                  End_Label (gnat_node));
3447
3448   /* Now build the tree for the declarations and statements inside this block.
3449      If this is SJLJ, set our jmp_buf as the current buffer.  */
3450   start_stmt_group ();
3451
3452   if (setjmp_longjmp)
3453     add_stmt (build_call_1_expr (set_jmpbuf_decl,
3454                                  build_unary_op (ADDR_EXPR, NULL_TREE,
3455                                                  gnu_jmpbuf_decl)));
3456
3457   if (Present (First_Real_Statement (gnat_node)))
3458     process_decls (Statements (gnat_node), Empty,
3459                    First_Real_Statement (gnat_node), true, true);
3460
3461   /* Generate code for each statement in the block.  */
3462   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3463                     ? First_Real_Statement (gnat_node)
3464                     : First (Statements (gnat_node)));
3465        Present (gnat_temp); gnat_temp = Next (gnat_temp))
3466     add_stmt (gnat_to_gnu (gnat_temp));
3467   gnu_inner_block = end_stmt_group ();
3468
3469   /* Now generate code for the two exception models, if either is relevant for
3470      this block.  */
3471   if (setjmp_longjmp)
3472     {
3473       tree *gnu_else_ptr = 0;
3474       tree gnu_handler;
3475
3476       /* Make a binding level for the exception handling declarations and code
3477          and set up gnu_except_ptr_stack for the handlers to use.  */
3478       start_stmt_group ();
3479       gnat_pushlevel ();
3480
3481       VEC_safe_push (tree, gc, gnu_except_ptr_stack,
3482                      create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
3483                                       build_pointer_type (except_type_node),
3484                                       build_call_0_expr (get_excptr_decl),
3485                                       false, false, false, false,
3486                                       NULL, gnat_node));
3487
3488       /* Generate code for each handler. The N_Exception_Handler case does the
3489          real work and returns a COND_EXPR for each handler, which we chain
3490          together here.  */
3491       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3492            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
3493         {
3494           gnu_expr = gnat_to_gnu (gnat_temp);
3495
3496           /* If this is the first one, set it as the outer one. Otherwise,
3497              point the "else" part of the previous handler to us. Then point
3498              to our "else" part.  */
3499           if (!gnu_else_ptr)
3500             add_stmt (gnu_expr);
3501           else
3502             *gnu_else_ptr = gnu_expr;
3503
3504           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3505         }
3506
3507       /* If none of the exception handlers did anything, re-raise but do not
3508          defer abortion.  */
3509       gnu_expr = build_call_1_expr (raise_nodefer_decl,
3510                                     VEC_last (tree, gnu_except_ptr_stack));
3511       set_expr_location_from_node
3512         (gnu_expr,
3513          Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
3514
3515       if (gnu_else_ptr)
3516         *gnu_else_ptr = gnu_expr;
3517       else
3518         add_stmt (gnu_expr);
3519
3520       /* End the binding level dedicated to the exception handlers and get the
3521          whole statement group.  */
3522       VEC_pop (tree, gnu_except_ptr_stack);
3523       gnat_poplevel ();
3524       gnu_handler = end_stmt_group ();
3525
3526       /* If the setjmp returns 1, we restore our incoming longjmp value and
3527          then check the handlers.  */
3528       start_stmt_group ();
3529       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
3530                                              gnu_jmpsave_decl),
3531                           gnat_node);
3532       add_stmt (gnu_handler);
3533       gnu_handler = end_stmt_group ();
3534
3535       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
3536       gnu_result = build3 (COND_EXPR, void_type_node,
3537                            (build_call_1_expr
3538                             (setjmp_decl,
3539                              build_unary_op (ADDR_EXPR, NULL_TREE,
3540                                              gnu_jmpbuf_decl))),
3541                            gnu_handler, gnu_inner_block);
3542     }
3543   else if (gcc_zcx)
3544     {
3545       tree gnu_handlers;
3546
3547       /* First make a block containing the handlers.  */
3548       start_stmt_group ();
3549       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3550            Present (gnat_temp);
3551            gnat_temp = Next_Non_Pragma (gnat_temp))
3552         add_stmt (gnat_to_gnu (gnat_temp));
3553       gnu_handlers = end_stmt_group ();
3554
3555       /* Now make the TRY_CATCH_EXPR for the block.  */
3556       gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
3557                            gnu_inner_block, gnu_handlers);
3558     }
3559   else
3560     gnu_result = gnu_inner_block;
3561
3562   /* Now close our outer block, if we had to make one.  */
3563   if (binding_for_block)
3564     {
3565       add_stmt (gnu_result);
3566       gnat_poplevel ();
3567       gnu_result = end_stmt_group ();
3568     }
3569
3570   return gnu_result;
3571 }
3572 \f
3573 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3574    to a GCC tree, which is returned.  This is the variant for Setjmp_Longjmp
3575    exception handling.  */
3576
3577 static tree
3578 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
3579 {
3580   /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
3581      an "if" statement to select the proper exceptions.  For "Others", exclude
3582      exceptions where Handled_By_Others is nonzero unless the All_Others flag
3583      is set. For "Non-ada", accept an exception if "Lang" is 'V'.  */
3584   tree gnu_choice = integer_zero_node;
3585   tree gnu_body = build_stmt_group (Statements (gnat_node), false);
3586   Node_Id gnat_temp;
3587
3588   for (gnat_temp = First (Exception_Choices (gnat_node));
3589        gnat_temp; gnat_temp = Next (gnat_temp))
3590     {
3591       tree this_choice;
3592
3593       if (Nkind (gnat_temp) == N_Others_Choice)
3594         {
3595           if (All_Others (gnat_temp))
3596             this_choice = integer_one_node;
3597           else
3598             this_choice
3599               = build_binary_op
3600                 (EQ_EXPR, boolean_type_node,
3601                  convert
3602                  (integer_type_node,
3603                   build_component_ref
3604                   (build_unary_op
3605                    (INDIRECT_REF, NULL_TREE,
3606                     VEC_last (tree, gnu_except_ptr_stack)),
3607                    get_identifier ("not_handled_by_others"), NULL_TREE,
3608                    false)),
3609                  integer_zero_node);
3610         }
3611
3612       else if (Nkind (gnat_temp) == N_Identifier
3613                || Nkind (gnat_temp) == N_Expanded_Name)
3614         {
3615           Entity_Id gnat_ex_id = Entity (gnat_temp);
3616           tree gnu_expr;
3617
3618           /* Exception may be a renaming. Recover original exception which is
3619              the one elaborated and registered.  */
3620           if (Present (Renamed_Object (gnat_ex_id)))
3621             gnat_ex_id = Renamed_Object (gnat_ex_id);
3622
3623           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3624
3625           this_choice
3626             = build_binary_op
3627               (EQ_EXPR, boolean_type_node,
3628                VEC_last (tree, gnu_except_ptr_stack),
3629                convert (TREE_TYPE (VEC_last (tree, gnu_except_ptr_stack)),
3630                         build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3631
3632           /* If this is the distinguished exception "Non_Ada_Error" (and we are
3633              in VMS mode), also allow a non-Ada exception (a VMS condition) t
3634              match.  */
3635           if (Is_Non_Ada_Error (Entity (gnat_temp)))
3636             {
3637               tree gnu_comp
3638                 = build_component_ref
3639                   (build_unary_op (INDIRECT_REF, NULL_TREE,
3640                                    VEC_last (tree, gnu_except_ptr_stack)),
3641                    get_identifier ("lang"), NULL_TREE, false);
3642
3643               this_choice
3644                 = build_binary_op
3645                   (TRUTH_ORIF_EXPR, boolean_type_node,
3646                    build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp,
3647                                     build_int_cst (TREE_TYPE (gnu_comp), 'V')),
3648                    this_choice);
3649             }
3650         }
3651       else
3652         gcc_unreachable ();
3653
3654       gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
3655                                     gnu_choice, this_choice);
3656     }
3657
3658   return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
3659 }
3660 \f
3661 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3662    to a GCC tree, which is returned.  This is the variant for ZCX.  */
3663
3664 static tree
3665 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
3666 {
3667   tree gnu_etypes_list = NULL_TREE;
3668   tree gnu_expr;
3669   tree gnu_etype;
3670   tree gnu_current_exc_ptr;
3671   tree gnu_incoming_exc_ptr;
3672   Node_Id gnat_temp;
3673
3674   /* We build a TREE_LIST of nodes representing what exception types this
3675      handler can catch, with special cases for others and all others cases.
3676
3677      Each exception type is actually identified by a pointer to the exception
3678      id, or to a dummy object for "others" and "all others".  */
3679   for (gnat_temp = First (Exception_Choices (gnat_node));
3680        gnat_temp; gnat_temp = Next (gnat_temp))
3681     {
3682       if (Nkind (gnat_temp) == N_Others_Choice)
3683         {
3684           tree gnu_expr
3685             = All_Others (gnat_temp) ? all_others_decl : others_decl;
3686
3687           gnu_etype
3688             = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3689         }
3690       else if (Nkind (gnat_temp) == N_Identifier
3691                || Nkind (gnat_temp) == N_Expanded_Name)
3692         {
3693           Entity_Id gnat_ex_id = Entity (gnat_temp);
3694
3695           /* Exception may be a renaming. Recover original exception which is
3696              the one elaborated and registered.  */
3697           if (Present (Renamed_Object (gnat_ex_id)))
3698             gnat_ex_id = Renamed_Object (gnat_ex_id);
3699
3700           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3701           gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3702
3703           /* The Non_Ada_Error case for VMS exceptions is handled
3704              by the personality routine.  */
3705         }
3706       else
3707         gcc_unreachable ();
3708
3709       /* The GCC interface expects NULL to be passed for catch all handlers, so
3710          it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
3711          is integer_zero_node.  It would not work, however, because GCC's
3712          notion of "catch all" is stronger than our notion of "others".  Until
3713          we correctly use the cleanup interface as well, doing that would
3714          prevent the "all others" handlers from being seen, because nothing
3715          can be caught beyond a catch all from GCC's point of view.  */
3716       gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3717     }
3718
3719   start_stmt_group ();
3720   gnat_pushlevel ();
3721
3722   /* Expand a call to the begin_handler hook at the beginning of the handler,
3723      and arrange for a call to the end_handler hook to occur on every possible
3724      exit path.
3725
3726      The hooks expect a pointer to the low level occurrence. This is required
3727      for our stack management scheme because a raise inside the handler pushes
3728      a new occurrence on top of the stack, which means that this top does not
3729      necessarily match the occurrence this handler was dealing with.
3730
3731      __builtin_eh_pointer references the exception occurrence being
3732      propagated. Upon handler entry, this is the exception for which the
3733      handler is triggered. This might not be the case upon handler exit,
3734      however, as we might have a new occurrence propagated by the handler's
3735      body, and the end_handler hook called as a cleanup in this context.
3736
3737      We use a local variable to retrieve the incoming value at handler entry
3738      time, and reuse it to feed the end_handler hook's argument at exit.  */
3739
3740   gnu_current_exc_ptr
3741     = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
3742                        1, integer_zero_node);
3743   gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3744                                           ptr_type_node, gnu_current_exc_ptr,
3745                                           false, false, false, false,
3746                                           NULL, gnat_node);
3747
3748   add_stmt_with_node (build_call_1_expr (begin_handler_decl,
3749                                          gnu_incoming_exc_ptr),
3750                       gnat_node);
3751   /* ??? We don't seem to have an End_Label at hand to set the location.  */
3752   add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
3753                Empty);
3754   add_stmt_list (Statements (gnat_node));
3755   gnat_poplevel ();
3756
3757   return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
3758                  end_stmt_group ());
3759 }
3760 \f
3761 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
3762
3763 static void
3764 Compilation_Unit_to_gnu (Node_Id gnat_node)
3765 {
3766   const Node_Id gnat_unit = Unit (gnat_node);
3767   const bool body_p = (Nkind (gnat_unit) == N_Package_Body
3768                        || Nkind (gnat_unit) == N_Subprogram_Body);
3769   const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
3770   /* Make the decl for the elaboration procedure.  */
3771   tree gnu_elab_proc_decl
3772     = create_subprog_decl
3773       (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
3774        NULL_TREE, void_ftype, NULL_TREE, false, true, false, true, NULL,
3775        gnat_unit);
3776   struct elab_info *info;
3777
3778   VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl);
3779   DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
3780
3781   /* Initialize the information structure for the function.  */
3782   allocate_struct_function (gnu_elab_proc_decl, false);
3783   set_cfun (NULL);
3784
3785   current_function_decl = NULL_TREE;
3786
3787   start_stmt_group ();
3788   gnat_pushlevel ();
3789
3790   /* For a body, first process the spec if there is one.  */
3791   if (Nkind (gnat_unit) == N_Package_Body
3792       || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
3793     add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
3794
3795   if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3796     {
3797       elaborate_all_entities (gnat_node);
3798
3799       if (Nkind (gnat_unit) == N_Subprogram_Declaration
3800           || Nkind (gnat_unit) == N_Generic_Package_Declaration
3801           || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
3802         return;
3803     }
3804
3805   process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
3806                  true, true);
3807   add_stmt (gnat_to_gnu (gnat_unit));
3808
3809   /* If we can inline, generate code for all the inlined subprograms.  */
3810   if (optimize)
3811     {
3812       Entity_Id gnat_entity;
3813
3814       for (gnat_entity = First_Inlined_Subprogram (gnat_node);
3815            Present (gnat_entity);
3816            gnat_entity = Next_Inlined_Subprogram (gnat_entity))
3817         {
3818           Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
3819
3820           if (Nkind (gnat_body) != N_Subprogram_Body)
3821             {
3822               /* ??? This really should always be present.  */
3823               if (No (Corresponding_Body (gnat_body)))
3824                 continue;
3825               gnat_body
3826                 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
3827             }
3828
3829           if (Present (gnat_body))
3830             {
3831               /* Define the entity first so we set DECL_EXTERNAL.  */
3832               gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
3833               add_stmt (gnat_to_gnu (gnat_body));
3834             }
3835         }
3836     }
3837
3838   /* Process any pragmas and actions following the unit.  */
3839   add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
3840   add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
3841   finalize_from_with_types ();
3842
3843   /* Save away what we've made so far and record this potential elaboration
3844      procedure.  */
3845   info = ggc_alloc_elab_info ();
3846   set_current_block_context (gnu_elab_proc_decl);
3847   gnat_poplevel ();
3848   DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
3849
3850   set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
3851
3852   info->next = elab_info_list;
3853   info->elab_proc = gnu_elab_proc_decl;
3854   info->gnat_node = gnat_node;
3855   elab_info_list = info;
3856
3857   /* Generate elaboration code for this unit, if necessary, and say whether
3858      we did or not.  */
3859   VEC_pop (tree, gnu_elab_proc_stack);
3860
3861   /* Invalidate the global renaming pointers.  This is necessary because
3862      stabilization of the renamed entities may create SAVE_EXPRs which
3863      have been tied to a specific elaboration routine just above.  */
3864   invalidate_global_renaming_pointers ();
3865 }
3866 \f
3867 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
3868    as gigi is concerned.  This is used to avoid conversions on the LHS.  */
3869
3870 static bool
3871 unchecked_conversion_nop (Node_Id gnat_node)
3872 {
3873   Entity_Id from_type, to_type;
3874
3875   /* The conversion must be on the LHS of an assignment or an actual parameter
3876      of a call.  Otherwise, even if the conversion was essentially a no-op, it
3877      could de facto ensure type consistency and this should be preserved.  */
3878   if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement
3879         && Name (Parent (gnat_node)) == gnat_node)
3880       && !((Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
3881             || Nkind (Parent (gnat_node)) == N_Function_Call)
3882            && Name (Parent (gnat_node)) != gnat_node))
3883     return false;
3884
3885   from_type = Etype (Expression (gnat_node));
3886
3887   /* We're interested in artificial conversions generated by the front-end
3888      to make private types explicit, e.g. in Expand_Assign_Array.  */
3889   if (!Is_Private_Type (from_type))
3890     return false;
3891
3892   from_type = Underlying_Type (from_type);
3893   to_type = Etype (gnat_node);
3894
3895   /* The direct conversion to the underlying type is a no-op.  */
3896   if (to_type == from_type)
3897     return true;
3898
3899   /* For an array subtype, the conversion to the PAT is a no-op.  */
3900   if (Ekind (from_type) == E_Array_Subtype
3901       && to_type == Packed_Array_Type (from_type))
3902     return true;
3903
3904   /* For a record subtype, the conversion to the type is a no-op.  */
3905   if (Ekind (from_type) == E_Record_Subtype
3906       && to_type == Etype (from_type))
3907     return true;
3908
3909   return false;
3910 }
3911
3912 /* This function is the driver of the GNAT to GCC tree transformation process.
3913    It is the entry point of the tree transformer.  GNAT_NODE is the root of
3914    some GNAT tree.  Return the root of the corresponding GCC tree.  If this
3915    is an expression, return the GCC equivalent of the expression.  If this
3916    is a statement, return the statement or add it to the current statement
3917    group, in which case anything returned is to be interpreted as occurring
3918    after anything added.  */
3919
3920 tree
3921 gnat_to_gnu (Node_Id gnat_node)
3922 {
3923   const Node_Kind kind = Nkind (gnat_node);
3924   bool went_into_elab_proc = false;
3925   tree gnu_result = error_mark_node; /* Default to no value.  */
3926   tree gnu_result_type = void_type_node;
3927   tree gnu_expr, gnu_lhs, gnu_rhs;
3928   Node_Id gnat_temp;
3929
3930   /* Save node number for error message and set location information.  */
3931   error_gnat_node = gnat_node;
3932   Sloc_to_locus (Sloc (gnat_node), &input_location);
3933
3934   /* If this node is a statement and we are only annotating types, return an
3935      empty statement list.  */
3936   if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
3937     return alloc_stmt_list ();
3938
3939   /* If this node is a non-static subexpression and we are only annotating
3940      types, make this into a NULL_EXPR.  */
3941   if (type_annotate_only
3942       && IN (kind, N_Subexpr)
3943       && kind != N_Identifier
3944       && !Compile_Time_Known_Value (gnat_node))
3945     return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
3946                    build_call_raise (CE_Range_Check_Failed, gnat_node,
3947                                      N_Raise_Constraint_Error));
3948
3949   if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
3950        && kind != N_Null_Statement)
3951       || kind == N_Procedure_Call_Statement
3952       || kind == N_Label
3953       || kind == N_Implicit_Label_Declaration
3954       || kind == N_Handled_Sequence_Of_Statements
3955       || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
3956     {
3957       tree current_elab_proc = get_elaboration_procedure ();
3958
3959       /* If this is a statement and we are at top level, it must be part of
3960          the elaboration procedure, so mark us as being in that procedure.  */
3961       if (!current_function_decl)
3962         {
3963           current_function_decl = current_elab_proc;
3964           went_into_elab_proc = true;
3965         }
3966
3967       /* If we are in the elaboration procedure, check if we are violating a
3968          No_Elaboration_Code restriction by having a statement there.  Don't
3969          check for a possible No_Elaboration_Code restriction violation on
3970          N_Handled_Sequence_Of_Statements, as we want to signal an error on
3971          every nested real statement instead.  This also avoids triggering
3972          spurious errors on dummy (empty) sequences created by the front-end
3973          for package bodies in some cases.  */
3974       if (current_function_decl == current_elab_proc
3975           && kind != N_Handled_Sequence_Of_Statements)
3976         Check_Elaboration_Code_Allowed (gnat_node);
3977     }
3978
3979   switch (kind)
3980     {
3981       /********************************/
3982       /* Chapter 2: Lexical Elements  */
3983       /********************************/
3984
3985     case N_Identifier:
3986     case N_Expanded_Name:
3987     case N_Operator_Symbol:
3988     case N_Defining_Identifier:
3989       gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
3990       break;
3991
3992     case N_Integer_Literal:
3993       {
3994         tree gnu_type;
3995
3996         /* Get the type of the result, looking inside any padding and
3997            justified modular types.  Then get the value in that type.  */
3998         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3999
4000         if (TREE_CODE (gnu_type) == RECORD_TYPE
4001             && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
4002           gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
4003
4004         gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
4005
4006         /* If the result overflows (meaning it doesn't fit in its base type),
4007            abort.  We would like to check that the value is within the range
4008            of the subtype, but that causes problems with subtypes whose usage
4009            will raise Constraint_Error and with biased representation, so
4010            we don't.  */
4011         gcc_assert (!TREE_OVERFLOW (gnu_result));
4012       }
4013       break;
4014
4015     case N_Character_Literal:
4016       /* If a Entity is present, it means that this was one of the
4017          literals in a user-defined character type.  In that case,
4018          just return the value in the CONST_DECL.  Otherwise, use the
4019          character code.  In that case, the base type should be an
4020          INTEGER_TYPE, but we won't bother checking for that.  */
4021       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4022       if (Present (Entity (gnat_node)))
4023         gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
4024       else
4025         gnu_result
4026           = build_int_cst_type
4027               (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
4028       break;
4029
4030     case N_Real_Literal:
4031       /* If this is of a fixed-point type, the value we want is the
4032          value of the corresponding integer.  */
4033       if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
4034         {
4035           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4036           gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
4037                                   gnu_result_type);
4038           gcc_assert (!TREE_OVERFLOW (gnu_result));
4039         }
4040
4041       /* We should never see a Vax_Float type literal, since the front end
4042          is supposed to transform these using appropriate conversions.  */
4043       else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
4044         gcc_unreachable ();
4045
4046       else
4047         {
4048           Ureal ur_realval = Realval (gnat_node);
4049
4050           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4051
4052           /* If the real value is zero, so is the result.  Otherwise,
4053              convert it to a machine number if it isn't already.  That
4054              forces BASE to 0 or 2 and simplifies the rest of our logic.  */
4055           if (UR_Is_Zero (ur_realval))
4056             gnu_result = convert (gnu_result_type, integer_zero_node);
4057           else
4058             {
4059               if (!Is_Machine_Number (gnat_node))
4060                 ur_realval
4061                   = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
4062                              ur_realval, Round_Even, gnat_node);
4063
4064               gnu_result
4065                 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
4066
4067               /* If we have a base of zero, divide by the denominator.
4068                  Otherwise, the base must be 2 and we scale the value, which
4069                  we know can fit in the mantissa of the type (hence the use
4070                  of that type above).  */
4071               if (No (Rbase (ur_realval)))
4072                 gnu_result
4073                   = build_binary_op (RDIV_EXPR,
4074                                      get_base_type (gnu_result_type),
4075                                      gnu_result,
4076                                      UI_To_gnu (Denominator (ur_realval),
4077                                                 gnu_result_type));
4078               else
4079                 {
4080                   REAL_VALUE_TYPE tmp;
4081
4082                   gcc_assert (Rbase (ur_realval) == 2);
4083                   real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
4084                               - UI_To_Int (Denominator (ur_realval)));
4085                   gnu_result = build_real (gnu_result_type, tmp);
4086                 }
4087             }
4088
4089           /* Now see if we need to negate the result.  Do it this way to
4090              properly handle -0.  */
4091           if (UR_Is_Negative (Realval (gnat_node)))
4092             gnu_result
4093               = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
4094                                 gnu_result);
4095         }
4096
4097       break;
4098
4099     case N_String_Literal:
4100       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4101       if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
4102         {
4103           String_Id gnat_string = Strval (gnat_node);
4104           int length = String_Length (gnat_string);
4105           int i;
4106           char *string;
4107           if (length >= ALLOCA_THRESHOLD)
4108             string = XNEWVEC (char, length + 1);
4109           else
4110             string = (char *) alloca (length + 1);
4111
4112           /* Build the string with the characters in the literal.  Note
4113              that Ada strings are 1-origin.  */
4114           for (i = 0; i < length; i++)
4115             string[i] = Get_String_Char (gnat_string, i + 1);
4116
4117           /* Put a null at the end of the string in case it's in a context
4118              where GCC will want to treat it as a C string.  */
4119           string[i] = 0;
4120
4121           gnu_result = build_string (length, string);
4122
4123           /* Strings in GCC don't normally have types, but we want
4124              this to not be converted to the array type.  */
4125           TREE_TYPE (gnu_result) = gnu_result_type;
4126
4127           if (length >= ALLOCA_THRESHOLD)
4128             free (string);
4129         }
4130       else
4131         {
4132           /* Build a list consisting of each character, then make
4133              the aggregate.  */
4134           String_Id gnat_string = Strval (gnat_node);
4135           int length = String_Length (gnat_string);
4136           int i;
4137           tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
4138           VEC(constructor_elt,gc) *gnu_vec
4139             = VEC_alloc (constructor_elt, gc, length);
4140
4141           for (i = 0; i < length; i++)
4142             {
4143               tree t = build_int_cst (TREE_TYPE (gnu_result_type),
4144                                       Get_String_Char (gnat_string, i + 1));
4145
4146               CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
4147               gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
4148                                          0);
4149             }
4150
4151           gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
4152         }
4153       break;
4154
4155     case N_Pragma:
4156       gnu_result = Pragma_to_gnu (gnat_node);
4157       break;
4158
4159     /**************************************/
4160     /* Chapter 3: Declarations and Types  */
4161     /**************************************/
4162
4163     case N_Subtype_Declaration:
4164     case N_Full_Type_Declaration:
4165     case N_Incomplete_Type_Declaration:
4166     case N_Private_Type_Declaration:
4167     case N_Private_Extension_Declaration:
4168     case N_Task_Type_Declaration:
4169       process_type (Defining_Entity (gnat_node));
4170       gnu_result = alloc_stmt_list ();
4171       break;
4172
4173     case N_Object_Declaration:
4174     case N_Exception_Declaration:
4175       gnat_temp = Defining_Entity (gnat_node);
4176       gnu_result = alloc_stmt_list ();
4177
4178       /* If we are just annotating types and this object has an unconstrained
4179          or task type, don't elaborate it.   */
4180       if (type_annotate_only
4181           && (((Is_Array_Type (Etype (gnat_temp))
4182                 || Is_Record_Type (Etype (gnat_temp)))
4183                && !Is_Constrained (Etype (gnat_temp)))
4184             || Is_Concurrent_Type (Etype (gnat_temp))))
4185         break;
4186
4187       if (Present (Expression (gnat_node))
4188           && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
4189           && (!type_annotate_only
4190               || Compile_Time_Known_Value (Expression (gnat_node))))
4191         {
4192           gnu_expr = gnat_to_gnu (Expression (gnat_node));
4193           if (Do_Range_Check (Expression (gnat_node)))
4194             gnu_expr
4195               = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
4196
4197           /* If this object has its elaboration delayed, we must force
4198              evaluation of GNU_EXPR right now and save it for when the object
4199              is frozen.  */
4200           if (Present (Freeze_Node (gnat_temp)))
4201             {
4202               if (TREE_CONSTANT (gnu_expr))
4203                 ;
4204               else if (global_bindings_p ())
4205                 gnu_expr
4206                   = create_var_decl (create_concat_name (gnat_temp, "init"),
4207                                      NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
4208                                      false, false, false, false,
4209                                      NULL, gnat_temp);
4210               else
4211                 gnu_expr = gnat_save_expr (gnu_expr);
4212
4213               save_gnu_tree (gnat_node, gnu_expr, true);
4214             }
4215         }
4216       else
4217         gnu_expr = NULL_TREE;
4218
4219       if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
4220         gnu_expr = NULL_TREE;
4221
4222       /* If this is a deferred constant with an address clause, we ignore the
4223          full view since the clause is on the partial view and we cannot have
4224          2 different GCC trees for the object.  The only bits of the full view
4225          we will use is the initializer, but it will be directly fetched.  */
4226       if (Ekind(gnat_temp) == E_Constant
4227           && Present (Address_Clause (gnat_temp))
4228           && Present (Full_View (gnat_temp)))
4229         save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
4230
4231       if (No (Freeze_Node (gnat_temp)))
4232         gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
4233       break;
4234
4235     case N_Object_Renaming_Declaration:
4236       gnat_temp = Defining_Entity (gnat_node);
4237
4238       /* Don't do anything if this renaming is handled by the front end or if
4239          we are just annotating types and this object has a composite or task
4240          type, don't elaborate it.  We return the result in case it has any
4241          SAVE_EXPRs in it that need to be evaluated here.  */
4242       if (!Is_Renaming_Of_Object (gnat_temp)
4243           && ! (type_annotate_only
4244                 && (Is_Array_Type (Etype (gnat_temp))
4245                     || Is_Record_Type (Etype (gnat_temp))
4246                     || Is_Concurrent_Type (Etype (gnat_temp)))))
4247         gnu_result
4248           = gnat_to_gnu_entity (gnat_temp,
4249                                 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
4250       else
4251         gnu_result = alloc_stmt_list ();
4252       break;
4253
4254     case N_Implicit_Label_Declaration:
4255       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
4256       gnu_result = alloc_stmt_list ();
4257       break;
4258
4259     case N_Exception_Renaming_Declaration:
4260     case N_Number_Declaration:
4261     case N_Package_Renaming_Declaration:
4262     case N_Subprogram_Renaming_Declaration:
4263       /* These are fully handled in the front end.  */
4264       gnu_result = alloc_stmt_list ();
4265       break;
4266
4267     /*************************************/
4268     /* Chapter 4: Names and Expressions  */
4269     /*************************************/
4270
4271     case N_Explicit_Dereference:
4272       gnu_result = gnat_to_gnu (Prefix (gnat_node));
4273       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4274       gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
4275       break;
4276
4277     case N_Indexed_Component:
4278       {
4279         tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
4280         tree gnu_type;
4281         int ndim;
4282         int i;
4283         Node_Id *gnat_expr_array;
4284
4285         gnu_array_object = maybe_implicit_deref (gnu_array_object);
4286
4287         /* Convert vector inputs to their representative array type, to fit
4288            what the code below expects.  */
4289         gnu_array_object = maybe_vector_array (gnu_array_object);
4290
4291         gnu_array_object = maybe_unconstrained_array (gnu_array_object);
4292
4293         /* If we got a padded type, remove it too.  */
4294         if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
4295           gnu_array_object
4296             = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
4297                        gnu_array_object);
4298
4299         gnu_result = gnu_array_object;
4300
4301         /* First compute the number of dimensions of the array, then
4302            fill the expression array, the order depending on whether
4303            this is a Convention_Fortran array or not.  */
4304         for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
4305              TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
4306              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
4307              ndim++, gnu_type = TREE_TYPE (gnu_type))
4308           ;
4309
4310         gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
4311
4312         if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
4313           for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
4314                i >= 0;
4315                i--, gnat_temp = Next (gnat_temp))
4316             gnat_expr_array[i] = gnat_temp;
4317         else
4318           for (i = 0, gnat_temp = First (Expressions (gnat_node));
4319                i < ndim;
4320                i++, gnat_temp = Next (gnat_temp))
4321             gnat_expr_array[i] = gnat_temp;
4322
4323         for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
4324              i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
4325           {
4326             gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
4327             gnat_temp = gnat_expr_array[i];
4328             gnu_expr = gnat_to_gnu (gnat_temp);
4329
4330             if (Do_Range_Check (gnat_temp))
4331               gnu_expr
4332                 = emit_index_check
4333                   (gnu_array_object, gnu_expr,
4334                    TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
4335                    TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
4336                    gnat_temp);
4337
4338             gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
4339                                           gnu_result, gnu_expr);
4340           }
4341       }
4342
4343       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4344       break;
4345
4346     case N_Slice:
4347       {
4348         Node_Id gnat_range_node = Discrete_Range (gnat_node);
4349         tree gnu_type;
4350
4351         gnu_result = gnat_to_gnu (Prefix (gnat_node));
4352         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4353
4354         /* Do any implicit dereferences of the prefix and do any needed
4355            range check.  */
4356         gnu_result = maybe_implicit_deref (gnu_result);
4357         gnu_result = maybe_unconstrained_array (gnu_result);
4358         gnu_type = TREE_TYPE (gnu_result);
4359         if (Do_Range_Check (gnat_range_node))
4360           {
4361             /* Get the bounds of the slice.  */
4362             tree gnu_index_type
4363               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
4364             tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
4365             tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
4366             /* Get the permitted bounds.  */
4367             tree gnu_base_index_type
4368               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
4369             tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
4370               (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
4371             tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
4372               (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
4373             tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
4374
4375            gnu_min_expr = gnat_protect_expr (gnu_min_expr);
4376            gnu_max_expr = gnat_protect_expr (gnu_max_expr);
4377
4378             /* Derive a good type to convert everything to.  */
4379             gnu_expr_type = get_base_type (gnu_index_type);
4380
4381             /* Test whether the minimum slice value is too small.  */
4382             gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
4383                                           convert (gnu_expr_type,
4384                                                    gnu_min_expr),
4385                                           convert (gnu_expr_type,
4386                                                    gnu_base_min_expr));
4387
4388             /* Test whether the maximum slice value is too large.  */
4389             gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
4390                                           convert (gnu_expr_type,
4391                                                    gnu_max_expr),
4392                                           convert (gnu_expr_type,
4393                                                    gnu_base_max_expr));
4394
4395             /* Build a slice index check that returns the low bound,
4396                assuming the slice is not empty.  */
4397             gnu_expr = emit_check
4398               (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
4399                                 gnu_expr_l, gnu_expr_h),
4400                gnu_min_expr, CE_Index_Check_Failed, gnat_node);
4401
4402            /* Build a conditional expression that does the index checks and
4403               returns the low bound if the slice is not empty (max >= min),
4404               and returns the naked low bound otherwise (max < min), unless
4405               it is non-constant and the high bound is; this prevents VRP
4406               from inferring bogus ranges on the unlikely path.  */
4407             gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
4408                                     build_binary_op (GE_EXPR, gnu_expr_type,
4409                                                      convert (gnu_expr_type,
4410                                                               gnu_max_expr),
4411                                                      convert (gnu_expr_type,
4412                                                               gnu_min_expr)),
4413                                     gnu_expr,
4414                                     TREE_CODE (gnu_min_expr) != INTEGER_CST
4415                                     && TREE_CODE (gnu_max_expr) == INTEGER_CST
4416                                     ? gnu_max_expr : gnu_min_expr);
4417           }
4418         else
4419           /* Simply return the naked low bound.  */
4420           gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
4421
4422         /* If this is a slice with non-constant size of an array with constant
4423            size, set the maximum size for the allocation of temporaries.  */
4424         if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
4425             && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
4426           TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
4427
4428         gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
4429                                       gnu_result, gnu_expr);
4430       }
4431       break;
4432
4433     case N_Selected_Component:
4434       {
4435         tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
4436         Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
4437         Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
4438         tree gnu_field;
4439
4440         while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
4441                || IN (Ekind (gnat_pref_type), Access_Kind))
4442           {
4443             if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
4444               gnat_pref_type = Underlying_Type (gnat_pref_type);
4445             else if (IN (Ekind (gnat_pref_type), Access_Kind))
4446               gnat_pref_type = Designated_Type (gnat_pref_type);
4447           }
4448
4449         gnu_prefix = maybe_implicit_deref (gnu_prefix);
4450
4451         /* For discriminant references in tagged types always substitute the
4452            corresponding discriminant as the actual selected component.  */
4453         if (Is_Tagged_Type (gnat_pref_type))
4454           while (Present (Corresponding_Discriminant (gnat_field)))
4455             gnat_field = Corresponding_Discriminant (gnat_field);
4456
4457         /* For discriminant references of untagged types always substitute the
4458            corresponding stored discriminant.  */
4459         else if (Present (Corresponding_Discriminant (gnat_field)))
4460           gnat_field = Original_Record_Component (gnat_field);
4461
4462         /* Handle extracting the real or imaginary part of a complex.
4463            The real part is the first field and the imaginary the last.  */
4464         if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
4465           gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
4466                                        ? REALPART_EXPR : IMAGPART_EXPR,
4467                                        NULL_TREE, gnu_prefix);
4468         else
4469           {
4470             gnu_field = gnat_to_gnu_field_decl (gnat_field);
4471
4472             /* If there are discriminants, the prefix might be evaluated more
4473                than once, which is a problem if it has side-effects.  */
4474             if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
4475                                    ? Designated_Type (Etype
4476                                                       (Prefix (gnat_node)))
4477                                    : Etype (Prefix (gnat_node))))
4478               gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL);
4479
4480             gnu_result
4481               = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
4482                                      (Nkind (Parent (gnat_node))
4483                                       == N_Attribute_Reference)
4484                                      && lvalue_required_for_attribute_p
4485                                         (Parent (gnat_node)));
4486           }
4487
4488         gcc_assert (gnu_result);
4489         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4490       }
4491       break;
4492
4493     case N_Attribute_Reference:
4494       {
4495         /* The attribute designator.  */
4496         const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
4497
4498         /* The Elab_Spec and Elab_Body attributes are special in that Prefix
4499            is a unit, not an object with a GCC equivalent.  */
4500         if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
4501           return
4502             create_subprog_decl (create_concat_name
4503                                  (Entity (Prefix (gnat_node)),
4504                                   attr == Attr_Elab_Body ? "elabb" : "elabs"),
4505                                  NULL_TREE, void_ftype, NULL_TREE, false,
4506                                  true, true, true, NULL, gnat_node);
4507
4508         gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
4509       }
4510       break;
4511
4512     case N_Reference:
4513       /* Like 'Access as far as we are concerned.  */
4514       gnu_result = gnat_to_gnu (Prefix (gnat_node));
4515       gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
4516       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4517       break;
4518
4519     case N_Aggregate:
4520     case N_Extension_Aggregate:
4521       {
4522         tree gnu_aggr_type;
4523
4524         /* ??? It is wrong to evaluate the type now, but there doesn't
4525            seem to be any other practical way of doing it.  */
4526
4527         gcc_assert (!Expansion_Delayed (gnat_node));
4528
4529         gnu_aggr_type = gnu_result_type
4530           = get_unpadded_type (Etype (gnat_node));
4531
4532         if (TREE_CODE (gnu_result_type) == RECORD_TYPE
4533             && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
4534           gnu_aggr_type
4535             = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
4536         else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
4537           gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
4538
4539         if (Null_Record_Present (gnat_node))
4540           gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
4541
4542         else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
4543                  || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
4544           gnu_result
4545             = assoc_to_constructor (Etype (gnat_node),
4546                                     First (Component_Associations (gnat_node)),
4547                                     gnu_aggr_type);
4548         else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
4549           gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
4550                                            gnu_aggr_type,
4551                                            Component_Type (Etype (gnat_node)));
4552         else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
4553           gnu_result
4554             = build_binary_op
4555               (COMPLEX_EXPR, gnu_aggr_type,
4556                gnat_to_gnu (Expression (First
4557                                         (Component_Associations (gnat_node)))),
4558                gnat_to_gnu (Expression
4559                             (Next
4560                              (First (Component_Associations (gnat_node))))));
4561         else
4562           gcc_unreachable ();
4563
4564         gnu_result = convert (gnu_result_type, gnu_result);
4565       }
4566       break;
4567
4568     case N_Null:
4569       if (TARGET_VTABLE_USES_DESCRIPTORS
4570           && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
4571           && Is_Dispatch_Table_Entity (Etype (gnat_node)))
4572         gnu_result = null_fdesc_node;
4573       else
4574         gnu_result = null_pointer_node;
4575       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4576       break;
4577
4578     case N_Type_Conversion:
4579     case N_Qualified_Expression:
4580       /* Get the operand expression.  */
4581       gnu_result = gnat_to_gnu (Expression (gnat_node));
4582       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4583
4584       gnu_result
4585         = convert_with_check (Etype (gnat_node), gnu_result,
4586                               Do_Overflow_Check (gnat_node),
4587                               Do_Range_Check (Expression (gnat_node)),
4588                               kind == N_Type_Conversion
4589                               && Float_Truncate (gnat_node), gnat_node);
4590       break;
4591
4592     case N_Unchecked_Type_Conversion:
4593       gnu_result = gnat_to_gnu (Expression (gnat_node));
4594
4595       /* Skip further processing if the conversion is deemed a no-op.  */
4596       if (unchecked_conversion_nop (gnat_node))
4597         {
4598           gnu_result_type = TREE_TYPE (gnu_result);
4599           break;
4600         }
4601
4602       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4603
4604       /* If the result is a pointer type, see if we are improperly
4605          converting to a stricter alignment.  */
4606       if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
4607           && IN (Ekind (Etype (gnat_node)), Access_Kind))
4608         {
4609           unsigned int align = known_alignment (gnu_result);
4610           tree gnu_obj_type = TREE_TYPE (gnu_result_type);
4611           unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
4612
4613           if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
4614             post_error_ne_tree_2
4615               ("?source alignment (^) '< alignment of & (^)",
4616                gnat_node, Designated_Type (Etype (gnat_node)),
4617                size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
4618         }
4619
4620       /* If we are converting a descriptor to a function pointer, first
4621          build the pointer.  */
4622       if (TARGET_VTABLE_USES_DESCRIPTORS
4623           && TREE_TYPE (gnu_result) == fdesc_type_node
4624           && POINTER_TYPE_P (gnu_result_type))
4625         gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
4626
4627       gnu_result = unchecked_convert (gnu_result_type, gnu_result,
4628                                       No_Truncation (gnat_node));
4629       break;
4630
4631     case N_In:
4632     case N_Not_In:
4633       {
4634         tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
4635         Node_Id gnat_range = Right_Opnd (gnat_node);
4636         tree gnu_low, gnu_high;
4637
4638         /* GNAT_RANGE is either an N_Range node or an identifier denoting a
4639            subtype.  */
4640         if (Nkind (gnat_range) == N_Range)
4641           {
4642             gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
4643             gnu_high = gnat_to_gnu (High_Bound (gnat_range));
4644           }
4645         else if (Nkind (gnat_range) == N_Identifier
4646                  || Nkind (gnat_range) == N_Expanded_Name)
4647           {
4648             tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
4649
4650             gnu_low = TYPE_MIN_VALUE (gnu_range_type);
4651             gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4652           }
4653         else
4654           gcc_unreachable ();
4655
4656         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4657
4658         /* If LOW and HIGH are identical, perform an equality test.  Otherwise,
4659            ensure that GNU_OBJ is evaluated only once and perform a full range
4660            test.  */
4661         if (operand_equal_p (gnu_low, gnu_high, 0))
4662           gnu_result
4663             = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
4664         else
4665           {
4666             tree t1, t2;
4667             gnu_obj = gnat_protect_expr (gnu_obj);
4668             t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
4669             if (EXPR_P (t1))
4670               set_expr_location_from_node (t1, gnat_node);
4671             t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
4672             if (EXPR_P (t2))
4673               set_expr_location_from_node (t2, gnat_node);
4674             gnu_result
4675               = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
4676           }
4677
4678         if (kind == N_Not_In)
4679           gnu_result
4680             = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
4681       }
4682       break;
4683
4684     case N_Op_Divide:
4685       gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4686       gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4687       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4688       gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
4689                                     ? RDIV_EXPR
4690                                     : (Rounded_Result (gnat_node)
4691                                        ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
4692                                     gnu_result_type, gnu_lhs, gnu_rhs);
4693       break;
4694
4695     case N_Op_Or:    case N_Op_And:      case N_Op_Xor:
4696       /* These can either be operations on booleans or on modular types.
4697          Fall through for boolean types since that's the way GNU_CODES is
4698          set up.  */
4699       if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
4700               Modular_Integer_Kind))
4701         {
4702           enum tree_code code
4703             = (kind == N_Op_Or ? BIT_IOR_EXPR
4704                : kind == N_Op_And ? BIT_AND_EXPR
4705                : BIT_XOR_EXPR);
4706
4707           gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4708           gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4709           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4710           gnu_result = build_binary_op (code, gnu_result_type,
4711                                         gnu_lhs, gnu_rhs);
4712           break;
4713         }
4714
4715       /* ... fall through ... */
4716
4717     case N_Op_Eq:    case N_Op_Ne:       case N_Op_Lt:
4718     case N_Op_Le:    case N_Op_Gt:       case N_Op_Ge:
4719     case N_Op_Add:   case N_Op_Subtract: case N_Op_Multiply:
4720     case N_Op_Mod:   case N_Op_Rem:
4721     case N_Op_Rotate_Left:
4722     case N_Op_Rotate_Right:
4723     case N_Op_Shift_Left:
4724     case N_Op_Shift_Right:
4725     case N_Op_Shift_Right_Arithmetic:
4726     case N_And_Then: case N_Or_Else:
4727       {
4728         enum tree_code code = gnu_codes[kind];
4729         bool ignore_lhs_overflow = false;
4730         location_t saved_location = input_location;
4731         tree gnu_type;
4732
4733         gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4734         gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4735         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
4736
4737         /* Pending generic support for efficient vector logical operations in
4738            GCC, convert vectors to their representative array type view and
4739            fallthrough.  */
4740         gnu_lhs = maybe_vector_array (gnu_lhs);
4741         gnu_rhs = maybe_vector_array (gnu_rhs);
4742
4743         /* If this is a comparison operator, convert any references to
4744            an unconstrained array value into a reference to the
4745            actual array.  */
4746         if (TREE_CODE_CLASS (code) == tcc_comparison)
4747           {
4748             gnu_lhs = maybe_unconstrained_array (gnu_lhs);
4749             gnu_rhs = maybe_unconstrained_array (gnu_rhs);
4750           }
4751
4752         /* If the result type is a private type, its full view may be a
4753            numeric subtype. The representation we need is that of its base
4754            type, given that it is the result of an arithmetic operation.  */
4755         else if (Is_Private_Type (Etype (gnat_node)))
4756           gnu_type = gnu_result_type
4757             = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
4758
4759         /* If this is a shift whose count is not guaranteed to be correct,
4760            we need to adjust the shift count.  */
4761         if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
4762           {
4763             tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
4764             tree gnu_max_shift
4765               = convert (gnu_count_type, TYPE_SIZE (gnu_type));
4766
4767             if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
4768               gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
4769                                          gnu_rhs, gnu_max_shift);
4770             else if (kind == N_Op_Shift_Right_Arithmetic)
4771               gnu_rhs
4772                 = build_binary_op
4773                   (MIN_EXPR, gnu_count_type,
4774                    build_binary_op (MINUS_EXPR,
4775                                     gnu_count_type,
4776                                     gnu_max_shift,
4777                                     convert (gnu_count_type,
4778                                              integer_one_node)),
4779                    gnu_rhs);
4780           }
4781
4782         /* For right shifts, the type says what kind of shift to do,
4783            so we may need to choose a different type.  In this case,
4784            we have to ignore integer overflow lest it propagates all
4785            the way down and causes a CE to be explicitly raised.  */
4786         if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
4787           {
4788             gnu_type = gnat_unsigned_type (gnu_type);
4789             ignore_lhs_overflow = true;
4790           }
4791         else if (kind == N_Op_Shift_Right_Arithmetic
4792                  && TYPE_UNSIGNED (gnu_type))
4793           {
4794             gnu_type = gnat_signed_type (gnu_type);
4795             ignore_lhs_overflow = true;
4796           }
4797
4798         if (gnu_type != gnu_result_type)
4799           {
4800             tree gnu_old_lhs = gnu_lhs;
4801             gnu_lhs = convert (gnu_type, gnu_lhs);
4802             if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
4803               TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
4804             gnu_rhs = convert (gnu_type, gnu_rhs);
4805           }
4806
4807         /* Instead of expanding overflow checks for addition, subtraction
4808            and multiplication itself, the front end will leave this to
4809            the back end when Backend_Overflow_Checks_On_Target is set.
4810            As the GCC back end itself does not know yet how to properly
4811            do overflow checking, do it here.  The goal is to push
4812            the expansions further into the back end over time.  */
4813         if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
4814             && (kind == N_Op_Add
4815                 || kind == N_Op_Subtract
4816                 || kind == N_Op_Multiply)
4817             && !TYPE_UNSIGNED (gnu_type)
4818             && !FLOAT_TYPE_P (gnu_type))
4819           gnu_result = build_binary_op_trapv (code, gnu_type,
4820                                               gnu_lhs, gnu_rhs, gnat_node);
4821         else
4822           {
4823             /* Some operations, e.g. comparisons of arrays, generate complex
4824                trees that need to be annotated while they are being built.  */
4825             input_location = saved_location;
4826             gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
4827           }
4828
4829         /* If this is a logical shift with the shift count not verified,
4830            we must return zero if it is too large.  We cannot compensate
4831            above in this case.  */
4832         if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
4833             && !Shift_Count_OK (gnat_node))
4834           gnu_result
4835             = build_cond_expr
4836               (gnu_type,
4837                build_binary_op (GE_EXPR, boolean_type_node,
4838                                 gnu_rhs,
4839                                 convert (TREE_TYPE (gnu_rhs),
4840                                          TYPE_SIZE (gnu_type))),
4841                convert (gnu_type, integer_zero_node),
4842                gnu_result);
4843       }
4844       break;
4845
4846     case N_Conditional_Expression:
4847       {
4848         tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
4849         tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
4850         tree gnu_false
4851           = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
4852
4853         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4854         gnu_result
4855           = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
4856       }
4857       break;
4858
4859     case N_Op_Plus:
4860       gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
4861       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4862       break;
4863
4864     case N_Op_Not:
4865       /* This case can apply to a boolean or a modular type.
4866          Fall through for a boolean operand since GNU_CODES is set
4867          up to handle this.  */
4868       if (Is_Modular_Integer_Type (Etype (gnat_node))
4869           || (Ekind (Etype (gnat_node)) == E_Private_Type
4870               && Is_Modular_Integer_Type (Full_View (Etype (gnat_node)))))
4871         {
4872           gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
4873           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4874           gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
4875                                        gnu_expr);
4876           break;
4877         }
4878
4879       /* ... fall through ... */
4880
4881     case N_Op_Minus:  case N_Op_Abs:
4882       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
4883
4884       if (Ekind (Etype (gnat_node)) != E_Private_Type)
4885         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4886       else
4887         gnu_result_type = get_unpadded_type (Base_Type
4888                                              (Full_View (Etype (gnat_node))));
4889
4890       if (Do_Overflow_Check (gnat_node)
4891           && !TYPE_UNSIGNED (gnu_result_type)
4892           && !FLOAT_TYPE_P (gnu_result_type))
4893         gnu_result
4894           = build_unary_op_trapv (gnu_codes[kind],
4895                                   gnu_result_type, gnu_expr, gnat_node);
4896       else
4897         gnu_result = build_unary_op (gnu_codes[kind],
4898                                      gnu_result_type, gnu_expr);
4899       break;
4900
4901     case N_Allocator:
4902       {
4903         tree gnu_init = 0;
4904         tree gnu_type;
4905         bool ignore_init_type = false;
4906
4907         gnat_temp = Expression (gnat_node);
4908
4909         /* The Expression operand can either be an N_Identifier or
4910            Expanded_Name, which must represent a type, or a
4911            N_Qualified_Expression, which contains both the object type and an
4912            initial value for the object.  */
4913         if (Nkind (gnat_temp) == N_Identifier
4914             || Nkind (gnat_temp) == N_Expanded_Name)
4915           gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
4916         else if (Nkind (gnat_temp) == N_Qualified_Expression)
4917           {
4918             Entity_Id gnat_desig_type
4919               = Designated_Type (Underlying_Type (Etype (gnat_node)));
4920
4921             ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
4922             gnu_init = gnat_to_gnu (Expression (gnat_temp));
4923
4924             gnu_init = maybe_unconstrained_array (gnu_init);
4925             if (Do_Range_Check (Expression (gnat_temp)))
4926               gnu_init
4927                 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
4928
4929             if (Is_Elementary_Type (gnat_desig_type)
4930                 || Is_Constrained (gnat_desig_type))
4931               {
4932                 gnu_type = gnat_to_gnu_type (gnat_desig_type);
4933                 gnu_init = convert (gnu_type, gnu_init);
4934               }
4935             else
4936               {
4937                 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
4938                 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4939                   gnu_type = TREE_TYPE (gnu_init);
4940
4941                 gnu_init = convert (gnu_type, gnu_init);
4942               }
4943           }
4944         else
4945           gcc_unreachable ();
4946
4947         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4948         return build_allocator (gnu_type, gnu_init, gnu_result_type,
4949                                 Procedure_To_Call (gnat_node),
4950                                 Storage_Pool (gnat_node), gnat_node,
4951                                 ignore_init_type);
4952       }
4953       break;
4954
4955     /**************************/
4956     /* Chapter 5: Statements  */
4957     /**************************/
4958
4959     case N_Label:
4960       gnu_result = build1 (LABEL_EXPR, void_type_node,
4961                            gnat_to_gnu (Identifier (gnat_node)));
4962       break;
4963
4964     case N_Null_Statement:
4965       /* When not optimizing, turn null statements from source into gotos to
4966          the next statement that the middle-end knows how to preserve.  */
4967       if (!optimize && Comes_From_Source (gnat_node))
4968         {
4969           tree stmt, label = create_label_decl (NULL_TREE);
4970           start_stmt_group ();
4971           stmt = build1 (GOTO_EXPR, void_type_node, label);
4972           set_expr_location_from_node (stmt, gnat_node);
4973           add_stmt (stmt);
4974           stmt = build1 (LABEL_EXPR, void_type_node, label);
4975           set_expr_location_from_node (stmt, gnat_node);
4976           add_stmt (stmt);
4977           gnu_result = end_stmt_group ();
4978         }
4979       else
4980         gnu_result = alloc_stmt_list ();
4981       break;
4982
4983     case N_Assignment_Statement:
4984       /* Get the LHS and RHS of the statement and convert any reference to an
4985          unconstrained array into a reference to the underlying array.  */
4986       gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
4987
4988       /* If the type has a size that overflows, convert this into raise of
4989          Storage_Error: execution shouldn't have gotten here anyway.  */
4990       if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
4991            && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
4992         gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
4993                                        N_Raise_Storage_Error);
4994       else if (Nkind (Expression (gnat_node)) == N_Function_Call)
4995         gnu_result
4996           = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs);
4997       else
4998         {
4999           gnu_rhs
5000             = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
5001
5002           /* If range check is needed, emit code to generate it.  */
5003           if (Do_Range_Check (Expression (gnat_node)))
5004             gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
5005                                         gnat_node);
5006
5007           gnu_result
5008             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
5009
5010           /* If the type being assigned is an array type and the two sides are
5011              not completely disjoint, play safe and use memmove.  But don't do
5012              it for a bit-packed array as it might not be byte-aligned.  */
5013           if (TREE_CODE (gnu_result) == MODIFY_EXPR
5014               && Is_Array_Type (Etype (Name (gnat_node)))
5015               && !Is_Bit_Packed_Array (Etype (Name (gnat_node)))
5016               && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
5017             {
5018               tree to, from, size, to_ptr, from_ptr, t;
5019
5020               to = TREE_OPERAND (gnu_result, 0);
5021               from = TREE_OPERAND (gnu_result, 1);
5022
5023               size = TYPE_SIZE_UNIT (TREE_TYPE (from));
5024               size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from);
5025
5026               to_ptr = build_fold_addr_expr (to);
5027               from_ptr = build_fold_addr_expr (from);
5028
5029               t = implicit_built_in_decls[BUILT_IN_MEMMOVE];
5030               gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
5031            }
5032         }
5033       break;
5034
5035     case N_If_Statement:
5036       {
5037         tree *gnu_else_ptr; /* Point to put next "else if" or "else".  */
5038
5039         /* Make the outer COND_EXPR.  Avoid non-determinism.  */
5040         gnu_result = build3 (COND_EXPR, void_type_node,
5041                              gnat_to_gnu (Condition (gnat_node)),
5042                              NULL_TREE, NULL_TREE);
5043         COND_EXPR_THEN (gnu_result)
5044           = build_stmt_group (Then_Statements (gnat_node), false);
5045         TREE_SIDE_EFFECTS (gnu_result) = 1;
5046         gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
5047
5048         /* Now make a COND_EXPR for each of the "else if" parts.  Put each
5049            into the previous "else" part and point to where to put any
5050            outer "else".  Also avoid non-determinism.  */
5051         if (Present (Elsif_Parts (gnat_node)))
5052           for (gnat_temp = First (Elsif_Parts (gnat_node));
5053                Present (gnat_temp); gnat_temp = Next (gnat_temp))
5054             {
5055               gnu_expr = build3 (COND_EXPR, void_type_node,
5056                                  gnat_to_gnu (Condition (gnat_temp)),
5057                                  NULL_TREE, NULL_TREE);
5058               COND_EXPR_THEN (gnu_expr)
5059                 = build_stmt_group (Then_Statements (gnat_temp), false);
5060               TREE_SIDE_EFFECTS (gnu_expr) = 1;
5061               set_expr_location_from_node (gnu_expr, gnat_temp);
5062               *gnu_else_ptr = gnu_expr;
5063               gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
5064             }
5065
5066         *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
5067       }
5068       break;
5069
5070     case N_Case_Statement:
5071       gnu_result = Case_Statement_to_gnu (gnat_node);
5072       break;
5073
5074     case N_Loop_Statement:
5075       gnu_result = Loop_Statement_to_gnu (gnat_node);
5076       break;
5077
5078     case N_Block_Statement:
5079       start_stmt_group ();
5080       gnat_pushlevel ();
5081       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
5082       add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
5083       gnat_poplevel ();
5084       gnu_result = end_stmt_group ();
5085
5086       if (Present (Identifier (gnat_node)))
5087         mark_out_of_scope (Entity (Identifier (gnat_node)));
5088       break;
5089
5090     case N_Exit_Statement:
5091       gnu_result
5092         = build2 (EXIT_STMT, void_type_node,
5093                   (Present (Condition (gnat_node))
5094                    ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
5095                   (Present (Name (gnat_node))
5096                    ? get_gnu_tree (Entity (Name (gnat_node)))
5097                    : VEC_last (tree, gnu_loop_label_stack)));
5098       break;
5099
5100     case N_Return_Statement:
5101       {
5102         tree gnu_ret_val, gnu_ret_obj;
5103
5104         /* If the subprogram is a function, we must return the expression.  */
5105         if (Present (Expression (gnat_node)))
5106           {
5107             tree gnu_subprog_type = TREE_TYPE (current_function_decl);
5108             tree gnu_ret_type = TREE_TYPE (gnu_subprog_type);
5109             tree gnu_result_decl = DECL_RESULT (current_function_decl);
5110             gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
5111
5112             /* If this function has copy-in/copy-out parameters, get the real
5113                variable and type for the return.  See Subprogram_to_gnu.  */
5114             if (TYPE_CI_CO_LIST (gnu_subprog_type))
5115               {
5116                 gnu_result_decl = VEC_last (tree, gnu_return_var_stack);
5117                 gnu_ret_type = TREE_TYPE (gnu_result_decl);
5118               }
5119
5120             /* Do not remove the padding from GNU_RET_VAL if the inner type is
5121                self-referential since we want to allocate the fixed size.  */
5122             if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
5123                 && TYPE_IS_PADDING_P
5124                    (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
5125                 && CONTAINS_PLACEHOLDER_P
5126                    (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
5127               gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
5128
5129             /* If the subprogram returns by direct reference, return a pointer
5130                to the return value.  */
5131             if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
5132                 || By_Ref (gnat_node))
5133               gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
5134
5135             /* Otherwise, if it returns an unconstrained array, we have to
5136                allocate a new version of the result and return it.  */
5137             else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
5138               {
5139                 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
5140                 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
5141                                                gnu_ret_val, gnu_ret_type,
5142                                                Procedure_To_Call (gnat_node),
5143                                                Storage_Pool (gnat_node),
5144                                                gnat_node, false);
5145               }
5146
5147             /* If the subprogram returns by invisible reference, dereference
5148                the pointer it is passed using the type of the return value
5149                and build the copy operation manually.  This ensures that we
5150                don't copy too much data, for example if the return type is
5151                unconstrained with a maximum size.  */
5152             if (TREE_ADDRESSABLE (gnu_subprog_type))
5153               {
5154                 gnu_ret_obj
5155                   = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
5156                                     gnu_result_decl);
5157                 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
5158                                               gnu_ret_obj, gnu_ret_val);
5159                 add_stmt_with_node (gnu_result, gnat_node);
5160                 gnu_ret_val = NULL_TREE;
5161                 gnu_ret_obj = gnu_result_decl;
5162               }
5163
5164             /* Otherwise, build a regular return.  */
5165             else
5166               gnu_ret_obj = gnu_result_decl;
5167           }
5168         else
5169           {
5170             gnu_ret_val = NULL_TREE;
5171             gnu_ret_obj = NULL_TREE;
5172           }
5173
5174         /* If we have a return label defined, convert this into a branch to
5175            that label.  The return proper will be handled elsewhere.  */
5176         if (VEC_last (tree, gnu_return_label_stack))
5177           {
5178             if (gnu_ret_obj)
5179               add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
5180                                          gnu_ret_val));
5181
5182             gnu_result = build1 (GOTO_EXPR, void_type_node,
5183                                  VEC_last (tree, gnu_return_label_stack));
5184             /* When not optimizing, make sure the return is preserved.  */
5185             if (!optimize && Comes_From_Source (gnat_node))
5186               DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0;
5187             break;
5188           }
5189
5190         gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
5191       }
5192       break;
5193
5194     case N_Goto_Statement:
5195       gnu_result = build1 (GOTO_EXPR, void_type_node,
5196                            gnat_to_gnu (Name (gnat_node)));
5197       break;
5198
5199     /***************************/
5200     /* Chapter 6: Subprograms  */
5201     /***************************/
5202
5203     case N_Subprogram_Declaration:
5204       /* Unless there is a freeze node, declare the subprogram.  We consider
5205          this a "definition" even though we're not generating code for
5206          the subprogram because we will be making the corresponding GCC
5207          node here.  */
5208
5209       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
5210         gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
5211                             NULL_TREE, 1);
5212       gnu_result = alloc_stmt_list ();
5213       break;
5214
5215     case N_Abstract_Subprogram_Declaration:
5216       /* This subprogram doesn't exist for code generation purposes, but we
5217          have to elaborate the types of any parameters and result, unless
5218          they are imported types (nothing to generate in this case).
5219
5220          The parameter list may contain types with freeze nodes, e.g. not null
5221          subtypes, so the subprogram itself may carry a freeze node, in which
5222          case its elaboration must be deferred.  */
5223
5224       /* Process the parameter types first.  */
5225       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
5226       for (gnat_temp
5227            = First_Formal_With_Extras
5228               (Defining_Entity (Specification (gnat_node)));
5229            Present (gnat_temp);
5230            gnat_temp = Next_Formal_With_Extras (gnat_temp))
5231         if (Is_Itype (Etype (gnat_temp))
5232             && !From_With_Type (Etype (gnat_temp)))
5233           gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
5234
5235       /* Then the result type, set to Standard_Void_Type for procedures.  */
5236       {
5237         Entity_Id gnat_temp_type
5238           = Etype (Defining_Entity (Specification (gnat_node)));
5239
5240         if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
5241           gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
5242       }
5243
5244       gnu_result = alloc_stmt_list ();
5245       break;
5246
5247     case N_Defining_Program_Unit_Name:
5248       /* For a child unit identifier go up a level to get the specification.
5249          We get this when we try to find the spec of a child unit package
5250          that is the compilation unit being compiled.  */
5251       gnu_result = gnat_to_gnu (Parent (gnat_node));
5252       break;
5253
5254     case N_Subprogram_Body:
5255       Subprogram_Body_to_gnu (gnat_node);
5256       gnu_result = alloc_stmt_list ();
5257       break;
5258
5259     case N_Function_Call:
5260     case N_Procedure_Call_Statement:
5261       gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
5262       break;
5263
5264     /************************/
5265     /* Chapter 7: Packages  */
5266     /************************/
5267
5268     case N_Package_Declaration:
5269       gnu_result = gnat_to_gnu (Specification (gnat_node));
5270       break;
5271
5272     case N_Package_Specification:
5273
5274       start_stmt_group ();
5275       process_decls (Visible_Declarations (gnat_node),
5276                      Private_Declarations (gnat_node), Empty, true, true);
5277       gnu_result = end_stmt_group ();
5278       break;
5279
5280     case N_Package_Body:
5281
5282       /* If this is the body of a generic package - do nothing.  */
5283       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
5284         {
5285           gnu_result = alloc_stmt_list ();
5286           break;
5287         }
5288
5289       start_stmt_group ();
5290       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
5291
5292       if (Present (Handled_Statement_Sequence (gnat_node)))
5293         add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
5294
5295       gnu_result = end_stmt_group ();
5296       break;
5297
5298     /********************************/
5299     /* Chapter 8: Visibility Rules  */
5300     /********************************/
5301
5302     case N_Use_Package_Clause:
5303     case N_Use_Type_Clause:
5304       /* Nothing to do here - but these may appear in list of declarations.  */
5305       gnu_result = alloc_stmt_list ();
5306       break;
5307
5308     /*********************/
5309     /* Chapter 9: Tasks  */
5310     /*********************/
5311
5312     case N_Protected_Type_Declaration:
5313       gnu_result = alloc_stmt_list ();
5314       break;
5315
5316     case N_Single_Task_Declaration:
5317       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
5318       gnu_result = alloc_stmt_list ();
5319       break;
5320
5321     /*********************************************************/
5322     /* Chapter 10: Program Structure and Compilation Issues  */
5323     /*********************************************************/
5324
5325     case N_Compilation_Unit:
5326       /* This is not called for the main unit on which gigi is invoked.  */
5327       Compilation_Unit_to_gnu (gnat_node);
5328       gnu_result = alloc_stmt_list ();
5329       break;
5330
5331     case N_Subprogram_Body_Stub:
5332     case N_Package_Body_Stub:
5333     case N_Protected_Body_Stub:
5334     case N_Task_Body_Stub:
5335       /* Simply process whatever unit is being inserted.  */
5336       gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
5337       break;
5338
5339     case N_Subunit:
5340       gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
5341       break;
5342
5343     /***************************/
5344     /* Chapter 11: Exceptions  */
5345     /***************************/
5346
5347     case N_Handled_Sequence_Of_Statements:
5348       /* If there is an At_End procedure attached to this node, and the EH
5349          mechanism is SJLJ, we must have at least a corresponding At_End
5350          handler, unless the No_Exception_Handlers restriction is set.  */
5351       gcc_assert (type_annotate_only
5352                   || Exception_Mechanism != Setjmp_Longjmp
5353                   || No (At_End_Proc (gnat_node))
5354                   || Present (Exception_Handlers (gnat_node))
5355                   || No_Exception_Handlers_Set ());
5356
5357       gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
5358       break;
5359
5360     case N_Exception_Handler:
5361       if (Exception_Mechanism == Setjmp_Longjmp)
5362         gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
5363       else if (Exception_Mechanism == Back_End_Exceptions)
5364         gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
5365       else
5366         gcc_unreachable ();
5367
5368       break;
5369
5370     case N_Push_Constraint_Error_Label:
5371       push_exception_label_stack (&gnu_constraint_error_label_stack,
5372                                   Exception_Label (gnat_node));
5373       break;
5374
5375     case N_Push_Storage_Error_Label:
5376       push_exception_label_stack (&gnu_storage_error_label_stack,
5377                                   Exception_Label (gnat_node));
5378       break;
5379
5380     case N_Push_Program_Error_Label:
5381       push_exception_label_stack (&gnu_program_error_label_stack,
5382                                   Exception_Label (gnat_node));
5383       break;
5384
5385     case N_Pop_Constraint_Error_Label:
5386       VEC_pop (tree, gnu_constraint_error_label_stack);
5387       break;
5388
5389     case N_Pop_Storage_Error_Label:
5390       VEC_pop (tree, gnu_storage_error_label_stack);
5391       break;
5392
5393     case N_Pop_Program_Error_Label:
5394       VEC_pop (tree, gnu_program_error_label_stack);
5395       break;
5396
5397     /******************************/
5398     /* Chapter 12: Generic Units  */
5399     /******************************/
5400
5401     case N_Generic_Function_Renaming_Declaration:
5402     case N_Generic_Package_Renaming_Declaration:
5403     case N_Generic_Procedure_Renaming_Declaration:
5404     case N_Generic_Package_Declaration:
5405     case N_Generic_Subprogram_Declaration:
5406     case N_Package_Instantiation:
5407     case N_Procedure_Instantiation:
5408     case N_Function_Instantiation:
5409       /* These nodes can appear on a declaration list but there is nothing to
5410          to be done with them.  */
5411       gnu_result = alloc_stmt_list ();
5412       break;
5413
5414     /**************************************************/
5415     /* Chapter 13: Representation Clauses and         */
5416     /*             Implementation-Dependent Features  */
5417     /**************************************************/
5418
5419     case N_Attribute_Definition_Clause:
5420       gnu_result = alloc_stmt_list ();
5421
5422       /* The only one we need to deal with is 'Address since, for the others,
5423          the front-end puts the information elsewhere.  */
5424       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
5425         break;
5426
5427       /* And we only deal with 'Address if the object has a Freeze node.  */
5428       gnat_temp = Entity (Name (gnat_node));
5429       if (No (Freeze_Node (gnat_temp)))
5430         break;
5431
5432       /* Get the value to use as the address and save it as the equivalent
5433          for the object.  When it is frozen, gnat_to_gnu_entity will do the
5434          right thing.  */
5435       save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
5436       break;
5437
5438     case N_Enumeration_Representation_Clause:
5439     case N_Record_Representation_Clause:
5440     case N_At_Clause:
5441       /* We do nothing with these.  SEM puts the information elsewhere.  */
5442       gnu_result = alloc_stmt_list ();
5443       break;
5444
5445     case N_Code_Statement:
5446       if (!type_annotate_only)
5447         {
5448           tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
5449           tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
5450           tree gnu_clobbers = NULL_TREE, tail;
5451           bool allows_mem, allows_reg, fake;
5452           int ninputs, noutputs, i;
5453           const char **oconstraints;
5454           const char *constraint;
5455           char *clobber;
5456
5457           /* First retrieve the 3 operand lists built by the front-end.  */
5458           Setup_Asm_Outputs (gnat_node);
5459           while (Present (gnat_temp = Asm_Output_Variable ()))
5460             {
5461               tree gnu_value = gnat_to_gnu (gnat_temp);
5462               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
5463                                                  (Asm_Output_Constraint ()));
5464
5465               gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
5466               Next_Asm_Output ();
5467             }
5468
5469           Setup_Asm_Inputs (gnat_node);
5470           while (Present (gnat_temp = Asm_Input_Value ()))
5471             {
5472               tree gnu_value = gnat_to_gnu (gnat_temp);
5473               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
5474                                                  (Asm_Input_Constraint ()));
5475
5476               gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
5477               Next_Asm_Input ();
5478             }
5479
5480           Clobber_Setup (gnat_node);
5481           while ((clobber = Clobber_Get_Next ()))
5482             gnu_clobbers
5483               = tree_cons (NULL_TREE,
5484                            build_string (strlen (clobber) + 1, clobber),
5485                            gnu_clobbers);
5486
5487           /* Then perform some standard checking and processing on the
5488              operands.  In particular, mark them addressable if needed.  */
5489           gnu_outputs = nreverse (gnu_outputs);
5490           noutputs = list_length (gnu_outputs);
5491           gnu_inputs = nreverse (gnu_inputs);
5492           ninputs = list_length (gnu_inputs);
5493           oconstraints = XALLOCAVEC (const char *, noutputs);
5494
5495           for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
5496             {
5497               tree output = TREE_VALUE (tail);
5498               constraint
5499                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
5500               oconstraints[i] = constraint;
5501
5502               if (parse_output_constraint (&constraint, i, ninputs, noutputs,
5503                                            &allows_mem, &allows_reg, &fake))
5504                 {
5505                   /* If the operand is going to end up in memory,
5506                      mark it addressable.  Note that we don't test
5507                      allows_mem like in the input case below; this
5508                      is modelled on the C front-end.  */
5509                   if (!allows_reg
5510                       && !gnat_mark_addressable (output))
5511                     output = error_mark_node;
5512                 }
5513               else
5514                 output = error_mark_node;
5515
5516               TREE_VALUE (tail) = output;
5517             }
5518
5519           for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
5520             {
5521               tree input = TREE_VALUE (tail);
5522               constraint
5523                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
5524
5525               if (parse_input_constraint (&constraint, i, ninputs, noutputs,
5526                                           0, oconstraints,
5527                                           &allows_mem, &allows_reg))
5528                 {
5529                   /* If the operand is going to end up in memory,
5530                      mark it addressable.  */
5531                   if (!allows_reg && allows_mem
5532                       && !gnat_mark_addressable (input))
5533                     input = error_mark_node;
5534                 }
5535               else
5536                 input = error_mark_node;
5537
5538               TREE_VALUE (tail) = input;
5539             }
5540
5541           gnu_result = build5 (ASM_EXPR,  void_type_node,
5542                                gnu_template, gnu_outputs,
5543                                gnu_inputs, gnu_clobbers, NULL_TREE);
5544           ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
5545         }
5546       else
5547         gnu_result = alloc_stmt_list ();
5548
5549       break;
5550
5551     /****************/
5552     /* Added Nodes  */
5553     /****************/
5554
5555     case N_Expression_With_Actions:
5556       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5557       /* This construct doesn't define a scope so we don't wrap the statement
5558          list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it
5559          from unsharing.  */
5560       gnu_result = build_stmt_group (Actions (gnat_node), false);
5561       gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
5562       TREE_SIDE_EFFECTS (gnu_result) = 1;
5563       gnu_expr = gnat_to_gnu (Expression (gnat_node));
5564       gnu_result
5565         = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
5566       break;
5567
5568     case N_Freeze_Entity:
5569       start_stmt_group ();
5570       process_freeze_entity (gnat_node);
5571       process_decls (Actions (gnat_node), Empty, Empty, true, true);
5572       gnu_result = end_stmt_group ();
5573       break;
5574
5575     case N_Itype_Reference:
5576       if (!present_gnu_tree (Itype (gnat_node)))
5577         process_type (Itype (gnat_node));
5578
5579       gnu_result = alloc_stmt_list ();
5580       break;
5581
5582     case N_Free_Statement:
5583       if (!type_annotate_only)
5584         {
5585           tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
5586           tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
5587           tree gnu_obj_type;
5588           tree gnu_actual_obj_type = 0;
5589           tree gnu_obj_size;
5590
5591           /* If this is a thin pointer, we must dereference it to create
5592              a fat pointer, then go back below to a thin pointer.  The
5593              reason for this is that we need a fat pointer someplace in
5594              order to properly compute the size.  */
5595           if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
5596             gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
5597                                       build_unary_op (INDIRECT_REF, NULL_TREE,
5598                                                       gnu_ptr));
5599
5600           /* If this is an unconstrained array, we know the object must
5601              have been allocated with the template in front of the object.
5602              So pass the template address, but get the total size.  Do this
5603              by converting to a thin pointer.  */
5604           if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
5605             gnu_ptr
5606               = convert (build_pointer_type
5607                          (TYPE_OBJECT_RECORD_TYPE
5608                           (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
5609                          gnu_ptr);
5610
5611           gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
5612
5613           if (Present (Actual_Designated_Subtype (gnat_node)))
5614             {
5615               gnu_actual_obj_type
5616                 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
5617
5618               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
5619                 gnu_actual_obj_type
5620                   = build_unc_object_type_from_ptr (gnu_ptr_type,
5621                                                     gnu_actual_obj_type,
5622                                                     get_identifier ("DEALLOC"),
5623                                                     false);
5624             }
5625           else
5626             gnu_actual_obj_type = gnu_obj_type;
5627
5628           gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
5629
5630           if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
5631               && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
5632             {
5633               tree gnu_char_ptr_type
5634                 = build_pointer_type (unsigned_char_type_node);
5635               tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
5636               gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
5637               gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
5638                                          gnu_ptr, gnu_pos);
5639             }
5640
5641           gnu_result
5642               = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
5643                                           Procedure_To_Call (gnat_node),
5644                                           Storage_Pool (gnat_node),
5645                                           gnat_node);
5646         }
5647       break;
5648
5649     case N_Raise_Constraint_Error:
5650     case N_Raise_Program_Error:
5651     case N_Raise_Storage_Error:
5652       {
5653         const int reason = UI_To_Int (Reason (gnat_node));
5654         const Node_Id cond = Condition (gnat_node);
5655         bool handled = false;
5656
5657         if (type_annotate_only)
5658           {
5659             gnu_result = alloc_stmt_list ();
5660             break;
5661           }
5662
5663         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5664
5665         if (Exception_Extra_Info
5666             && !No_Exception_Handlers_Set ()
5667             && !get_exception_label (kind)
5668             && TREE_CODE (gnu_result_type) == VOID_TYPE
5669             && Present (cond))
5670           {
5671             if (reason == CE_Access_Check_Failed)
5672               {
5673                 gnu_result = build_call_raise_column (reason, gnat_node);
5674                 handled = true;
5675               }
5676             else if ((reason == CE_Index_Check_Failed
5677                       || reason == CE_Range_Check_Failed
5678                       || reason == CE_Invalid_Data)
5679                      && Nkind (cond) == N_Op_Not
5680                      && Nkind (Right_Opnd (cond)) == N_In
5681                      && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range)
5682               {
5683                 Node_Id op = Right_Opnd (cond);  /* N_In node */
5684                 Node_Id index = Left_Opnd (op);
5685                 Node_Id type = Etype (index);
5686
5687                 if (Is_Type (type)
5688                     && Known_Esize (type)
5689                     && UI_To_Int (Esize (type)) <= 32)
5690                   {
5691                     Node_Id right_op = Right_Opnd (op);
5692                     gnu_result
5693                       = build_call_raise_range
5694                         (reason, gnat_node,
5695                          gnat_to_gnu (index),                  /* index */
5696                          gnat_to_gnu (Low_Bound (right_op)),   /* first */
5697                          gnat_to_gnu (High_Bound (right_op))); /* last  */
5698                     handled = true;
5699                   }
5700               }
5701           }
5702
5703         if (handled)
5704           {
5705             set_expr_location_from_node (gnu_result, gnat_node);
5706             gnu_result = build3 (COND_EXPR, void_type_node,
5707                                  gnat_to_gnu (cond),
5708                                  gnu_result, alloc_stmt_list ());
5709           }
5710         else
5711           {
5712             gnu_result = build_call_raise (reason, gnat_node, kind);
5713
5714             /* If the type is VOID, this is a statement, so we need to generate
5715                the code for the call.  Handle a Condition, if there is one.  */
5716             if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5717               {
5718                 set_expr_location_from_node (gnu_result, gnat_node);
5719                 if (Present (cond))
5720                   gnu_result = build3 (COND_EXPR, void_type_node,
5721                                        gnat_to_gnu (cond),
5722                                        gnu_result, alloc_stmt_list ());
5723               }
5724             else
5725               gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
5726           }
5727       }
5728       break;
5729
5730     case N_Validate_Unchecked_Conversion:
5731       {
5732         Entity_Id gnat_target_type = Target_Type (gnat_node);
5733         tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
5734         tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
5735
5736         /* No need for any warning in this case.  */
5737         if (!flag_strict_aliasing)
5738           ;
5739
5740         /* If the result is a pointer type, see if we are either converting
5741            from a non-pointer or from a pointer to a type with a different
5742            alias set and warn if so.  If the result is defined in the same
5743            unit as this unchecked conversion, we can allow this because we
5744            can know to make the pointer type behave properly.  */
5745         else if (POINTER_TYPE_P (gnu_target_type)
5746                  && !In_Same_Source_Unit (gnat_target_type, gnat_node)
5747                  && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
5748           {
5749             tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
5750                                          ? TREE_TYPE (gnu_source_type)
5751                                          : NULL_TREE;
5752             tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
5753
5754             if ((TYPE_DUMMY_P (gnu_target_desig_type)
5755                  || get_alias_set (gnu_target_desig_type) != 0)
5756                 && (!POINTER_TYPE_P (gnu_source_type)
5757                     || (TYPE_DUMMY_P (gnu_source_desig_type)
5758                         != TYPE_DUMMY_P (gnu_target_desig_type))
5759                     || (TYPE_DUMMY_P (gnu_source_desig_type)
5760                         && gnu_source_desig_type != gnu_target_desig_type)
5761                     || !alias_sets_conflict_p
5762                         (get_alias_set (gnu_source_desig_type),
5763                          get_alias_set (gnu_target_desig_type))))
5764               {
5765                 post_error_ne
5766                   ("?possible aliasing problem for type&",
5767                    gnat_node, Target_Type (gnat_node));
5768                 post_error
5769                   ("\\?use -fno-strict-aliasing switch for references",
5770                    gnat_node);
5771                 post_error_ne
5772                   ("\\?or use `pragma No_Strict_Aliasing (&);`",
5773                    gnat_node, Target_Type (gnat_node));
5774               }
5775           }
5776
5777         /* But if the result is a fat pointer type, we have no mechanism to
5778            do that, so we unconditionally warn in problematic cases.  */
5779         else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
5780           {
5781             tree gnu_source_array_type
5782               = TYPE_IS_FAT_POINTER_P (gnu_source_type)
5783                 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
5784                 : NULL_TREE;
5785             tree gnu_target_array_type
5786               = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
5787
5788             if ((TYPE_DUMMY_P (gnu_target_array_type)
5789                  || get_alias_set (gnu_target_array_type) != 0)
5790                 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
5791                     || (TYPE_DUMMY_P (gnu_source_array_type)
5792                         != TYPE_DUMMY_P (gnu_target_array_type))
5793                     || (TYPE_DUMMY_P (gnu_source_array_type)
5794                         && gnu_source_array_type != gnu_target_array_type)
5795                     || !alias_sets_conflict_p
5796                         (get_alias_set (gnu_source_array_type),
5797                          get_alias_set (gnu_target_array_type))))
5798               {
5799                 post_error_ne
5800                   ("?possible aliasing problem for type&",
5801                    gnat_node, Target_Type (gnat_node));
5802                 post_error
5803                   ("\\?use -fno-strict-aliasing switch for references",
5804                    gnat_node);
5805               }
5806           }
5807       }
5808       gnu_result = alloc_stmt_list ();
5809       break;
5810
5811     default:
5812       /* SCIL nodes require no processing for GCC.  Other nodes should only
5813          be present when annotating types.  */
5814       gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only);
5815       gnu_result = alloc_stmt_list ();
5816     }
5817
5818   /* If we pushed the processing of the elaboration routine, pop it back.  */
5819   if (went_into_elab_proc)
5820     current_function_decl = NULL_TREE;
5821
5822   /* When not optimizing, turn boolean rvalues B into B != false tests
5823      so that the code just below can put the location information of the
5824      reference to B on the inequality operator for better debug info.  */
5825   if (!optimize
5826       && TREE_CODE (gnu_result) != INTEGER_CST
5827       && (kind == N_Identifier
5828           || kind == N_Expanded_Name
5829           || kind == N_Explicit_Dereference
5830           || kind == N_Function_Call
5831           || kind == N_Indexed_Component
5832           || kind == N_Selected_Component)
5833       && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
5834       && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
5835     gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
5836                                   convert (gnu_result_type, gnu_result),
5837                                   convert (gnu_result_type,
5838                                            boolean_false_node));
5839
5840   /* Set the location information on the result.  Note that we may have
5841      no result if we tried to build a CALL_EXPR node to a procedure with
5842      no side-effects and optimization is enabled.  */
5843   if (gnu_result && EXPR_P (gnu_result))
5844     set_gnu_expr_location_from_node (gnu_result, gnat_node);
5845
5846   /* If we're supposed to return something of void_type, it means we have
5847      something we're elaborating for effect, so just return.  */
5848   if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5849     return gnu_result;
5850
5851   /* If the result is a constant that overflowed, raise Constraint_Error.  */
5852   if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
5853     {
5854       post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
5855       gnu_result
5856         = build1 (NULL_EXPR, gnu_result_type,
5857                   build_call_raise (CE_Overflow_Check_Failed, gnat_node,
5858                                     N_Raise_Constraint_Error));
5859     }
5860
5861   /* If our result has side-effects and is of an unconstrained type,
5862      make a SAVE_EXPR so that we can be sure it will only be referenced
5863      once.  Note we must do this before any conversions.  */
5864   if (TREE_SIDE_EFFECTS (gnu_result)
5865       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
5866           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
5867     gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
5868
5869   /* Now convert the result to the result type, unless we are in one of the
5870      following cases:
5871
5872        1. If this is the Name of an assignment statement or a parameter of
5873           a procedure call, return the result almost unmodified since the
5874           RHS will have to be converted to our type in that case, unless
5875           the result type has a simpler size.  Likewise if there is just
5876           a no-op unchecked conversion in-between.  Similarly, don't convert
5877           integral types that are the operands of an unchecked conversion
5878           since we need to ignore those conversions (for 'Valid).
5879
5880        2. If we have a label (which doesn't have any well-defined type), a
5881           field or an error, return the result almost unmodified.  Similarly,
5882           if the two types are record types with the same name, don't convert.
5883           This will be the case when we are converting from a packable version
5884           of a type to its original type and we need those conversions to be
5885           NOPs in order for assignments into these types to work properly.
5886
5887        3. If the type is void or if we have no result, return error_mark_node
5888           to show we have no result.
5889
5890        4. Finally, if the type of the result is already correct.  */
5891
5892   if (Present (Parent (gnat_node))
5893       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
5894            && Name (Parent (gnat_node)) == gnat_node)
5895           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
5896               && unchecked_conversion_nop (Parent (gnat_node)))
5897           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
5898               && Name (Parent (gnat_node)) != gnat_node)
5899           || Nkind (Parent (gnat_node)) == N_Parameter_Association
5900           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
5901               && !AGGREGATE_TYPE_P (gnu_result_type)
5902               && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
5903       && !(TYPE_SIZE (gnu_result_type)
5904            && TYPE_SIZE (TREE_TYPE (gnu_result))
5905            && (AGGREGATE_TYPE_P (gnu_result_type)
5906                == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
5907            && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
5908                 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
5909                     != INTEGER_CST))
5910                || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
5911                    && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
5912                    && (CONTAINS_PLACEHOLDER_P
5913                        (TYPE_SIZE (TREE_TYPE (gnu_result))))))
5914            && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
5915                 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
5916     {
5917       /* Remove padding only if the inner object is of self-referential
5918          size: in that case it must be an object of unconstrained type
5919          with a default discriminant and we want to avoid copying too
5920          much data.  */
5921       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
5922           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
5923                                      (TREE_TYPE (gnu_result))))))
5924         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
5925                               gnu_result);
5926     }
5927
5928   else if (TREE_CODE (gnu_result) == LABEL_DECL
5929            || TREE_CODE (gnu_result) == FIELD_DECL
5930            || TREE_CODE (gnu_result) == ERROR_MARK
5931            || (TYPE_NAME (gnu_result_type)
5932                == TYPE_NAME (TREE_TYPE (gnu_result))
5933                && TREE_CODE (gnu_result_type) == RECORD_TYPE
5934                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
5935     {
5936       /* Remove any padding.  */
5937       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
5938         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
5939                               gnu_result);
5940     }
5941
5942   else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
5943     gnu_result = error_mark_node;
5944
5945   else if (gnu_result_type != TREE_TYPE (gnu_result))
5946     gnu_result = convert (gnu_result_type, gnu_result);
5947
5948   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result.  */
5949   while ((TREE_CODE (gnu_result) == NOP_EXPR
5950           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
5951          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
5952     gnu_result = TREE_OPERAND (gnu_result, 0);
5953
5954   return gnu_result;
5955 }
5956 \f
5957 /* Subroutine of above to push the exception label stack.  GNU_STACK is
5958    a pointer to the stack to update and GNAT_LABEL, if present, is the
5959    label to push onto the stack.  */
5960
5961 static void
5962 push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label)
5963 {
5964   tree gnu_label = (Present (gnat_label)
5965                     ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
5966                     : NULL_TREE);
5967
5968   VEC_safe_push (tree, gc, *gnu_stack, gnu_label);
5969 }
5970 \f
5971 /* Record the current code position in GNAT_NODE.  */
5972
5973 static void
5974 record_code_position (Node_Id gnat_node)
5975 {
5976   tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
5977
5978   add_stmt_with_node (stmt_stmt, gnat_node);
5979   save_gnu_tree (gnat_node, stmt_stmt, true);
5980 }
5981
5982 /* Insert the code for GNAT_NODE at the position saved for that node.  */
5983
5984 static void
5985 insert_code_for (Node_Id gnat_node)
5986 {
5987   STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
5988   save_gnu_tree (gnat_node, NULL_TREE, true);
5989 }
5990 \f
5991 /* Start a new statement group chained to the previous group.  */
5992
5993 void
5994 start_stmt_group (void)
5995 {
5996   struct stmt_group *group = stmt_group_free_list;
5997
5998   /* First see if we can get one from the free list.  */
5999   if (group)
6000     stmt_group_free_list = group->previous;
6001   else
6002     group = ggc_alloc_stmt_group ();
6003
6004   group->previous = current_stmt_group;
6005   group->stmt_list = group->block = group->cleanups = NULL_TREE;
6006   current_stmt_group = group;
6007 }
6008
6009 /* Add GNU_STMT to the current statement group.  If it is an expression with
6010    no effects, it is ignored.  */
6011
6012 void
6013 add_stmt (tree gnu_stmt)
6014 {
6015   append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
6016 }
6017
6018 /* Similar, but the statement is always added, regardless of side-effects.  */
6019
6020 void
6021 add_stmt_force (tree gnu_stmt)
6022 {
6023   append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
6024 }
6025
6026 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE.  */
6027
6028 void
6029 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
6030 {
6031   if (Present (gnat_node))
6032     set_expr_location_from_node (gnu_stmt, gnat_node);
6033   add_stmt (gnu_stmt);
6034 }
6035
6036 /* Similar, but the statement is always added, regardless of side-effects.  */
6037
6038 void
6039 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
6040 {
6041   if (Present (gnat_node))
6042     set_expr_location_from_node (gnu_stmt, gnat_node);
6043   add_stmt_force (gnu_stmt);
6044 }
6045
6046 /* Add a declaration statement for GNU_DECL to the current statement group.
6047    Get SLOC from Entity_Id.  */
6048
6049 void
6050 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
6051 {
6052   tree type = TREE_TYPE (gnu_decl);
6053   tree gnu_stmt, gnu_init, t;
6054
6055   /* If this is a variable that Gigi is to ignore, we may have been given
6056      an ERROR_MARK.  So test for it.  We also might have been given a
6057      reference for a renaming.  So only do something for a decl.  Also
6058      ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE.  */
6059   if (!DECL_P (gnu_decl)
6060       || (TREE_CODE (gnu_decl) == TYPE_DECL
6061           && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
6062     return;
6063
6064   gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
6065
6066   /* If we are global, we don't want to actually output the DECL_EXPR for
6067      this decl since we already have evaluated the expressions in the
6068      sizes and positions as globals and doing it again would be wrong.  */
6069   if (global_bindings_p ())
6070     {
6071       /* Mark everything as used to prevent node sharing with subprograms.
6072          Note that walk_tree knows how to deal with TYPE_DECL, but neither
6073          VAR_DECL nor CONST_DECL.  This appears to be somewhat arbitrary.  */
6074       MARK_VISITED (gnu_stmt);
6075       if (TREE_CODE (gnu_decl) == VAR_DECL
6076           || TREE_CODE (gnu_decl) == CONST_DECL)
6077         {
6078           MARK_VISITED (DECL_SIZE (gnu_decl));
6079           MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
6080           MARK_VISITED (DECL_INITIAL (gnu_decl));
6081         }
6082       /* In any case, we have to deal with our own TYPE_ADA_SIZE field.  */
6083       else if (TREE_CODE (gnu_decl) == TYPE_DECL
6084                && ((TREE_CODE (type) == RECORD_TYPE
6085                     && !TYPE_FAT_POINTER_P (type))
6086                    || TREE_CODE (type) == UNION_TYPE
6087                    || TREE_CODE (type) == QUAL_UNION_TYPE))
6088         MARK_VISITED (TYPE_ADA_SIZE (type));
6089     }
6090   else if (!DECL_EXTERNAL (gnu_decl))
6091     add_stmt_with_node (gnu_stmt, gnat_entity);
6092
6093   /* If this is a variable and an initializer is attached to it, it must be
6094      valid for the context.  Similar to init_const in create_var_decl_1.  */
6095   if (TREE_CODE (gnu_decl) == VAR_DECL
6096       && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
6097       && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
6098           || (TREE_STATIC (gnu_decl)
6099               && !initializer_constant_valid_p (gnu_init,
6100                                                 TREE_TYPE (gnu_init)))))
6101     {
6102       /* If GNU_DECL has a padded type, convert it to the unpadded
6103          type so the assignment is done properly.  */
6104       if (TYPE_IS_PADDING_P (type))
6105         t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
6106       else
6107         t = gnu_decl;
6108
6109       gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
6110
6111       DECL_INITIAL (gnu_decl) = NULL_TREE;
6112       if (TREE_READONLY (gnu_decl))
6113         {
6114           TREE_READONLY (gnu_decl) = 0;
6115           DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
6116         }
6117
6118       add_stmt_with_node (gnu_stmt, gnat_entity);
6119     }
6120 }
6121
6122 /* Callback for walk_tree to mark the visited trees rooted at *TP.  */
6123
6124 static tree
6125 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
6126 {
6127   tree t = *tp;
6128
6129   if (TREE_VISITED (t))
6130     *walk_subtrees = 0;
6131
6132   /* Don't mark a dummy type as visited because we want to mark its sizes
6133      and fields once it's filled in.  */
6134   else if (!TYPE_IS_DUMMY_P (t))
6135     TREE_VISITED (t) = 1;
6136
6137   if (TYPE_P (t))
6138     TYPE_SIZES_GIMPLIFIED (t) = 1;
6139
6140   return NULL_TREE;
6141 }
6142
6143 /* Mark nodes rooted at T with TREE_VISITED and types as having their
6144    sized gimplified.  We use this to indicate all variable sizes and
6145    positions in global types may not be shared by any subprogram.  */
6146
6147 void
6148 mark_visited (tree t)
6149 {
6150   walk_tree (&t, mark_visited_r, NULL, NULL);
6151 }
6152
6153 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
6154    set its location to that of GNAT_NODE if present.  */
6155
6156 static void
6157 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
6158 {
6159   if (Present (gnat_node))
6160     set_expr_location_from_node (gnu_cleanup, gnat_node);
6161   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
6162 }
6163
6164 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
6165
6166 void
6167 set_block_for_group (tree gnu_block)
6168 {
6169   gcc_assert (!current_stmt_group->block);
6170   current_stmt_group->block = gnu_block;
6171 }
6172
6173 /* Return code corresponding to the current code group.  It is normally
6174    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
6175    BLOCK or cleanups were set.  */
6176
6177 tree
6178 end_stmt_group (void)
6179 {
6180   struct stmt_group *group = current_stmt_group;
6181   tree gnu_retval = group->stmt_list;
6182
6183   /* If this is a null list, allocate a new STATEMENT_LIST.  Then, if there
6184      are cleanups, make a TRY_FINALLY_EXPR.  Last, if there is a BLOCK,
6185      make a BIND_EXPR.  Note that we nest in that because the cleanup may
6186      reference variables in the block.  */
6187   if (gnu_retval == NULL_TREE)
6188     gnu_retval = alloc_stmt_list ();
6189
6190   if (group->cleanups)
6191     gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
6192                          group->cleanups);
6193
6194   if (current_stmt_group->block)
6195     gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
6196                          gnu_retval, group->block);
6197
6198   /* Remove this group from the stack and add it to the free list.  */
6199   current_stmt_group = group->previous;
6200   group->previous = stmt_group_free_list;
6201   stmt_group_free_list = group;
6202
6203   return gnu_retval;
6204 }
6205
6206 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
6207    statements.*/
6208
6209 static void
6210 add_stmt_list (List_Id gnat_list)
6211 {
6212   Node_Id gnat_node;
6213
6214   if (Present (gnat_list))
6215     for (gnat_node = First (gnat_list); Present (gnat_node);
6216          gnat_node = Next (gnat_node))
6217       add_stmt (gnat_to_gnu (gnat_node));
6218 }
6219
6220 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
6221    If BINDING_P is true, push and pop a binding level around the list.  */
6222
6223 static tree
6224 build_stmt_group (List_Id gnat_list, bool binding_p)
6225 {
6226   start_stmt_group ();
6227   if (binding_p)
6228     gnat_pushlevel ();
6229
6230   add_stmt_list (gnat_list);
6231   if (binding_p)
6232     gnat_poplevel ();
6233
6234   return end_stmt_group ();
6235 }
6236 \f
6237 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
6238
6239 int
6240 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
6241                     gimple_seq *post_p ATTRIBUTE_UNUSED)
6242 {
6243   tree expr = *expr_p;
6244   tree op;
6245
6246   if (IS_ADA_STMT (expr))
6247     return gnat_gimplify_stmt (expr_p);
6248
6249   switch (TREE_CODE (expr))
6250     {
6251     case NULL_EXPR:
6252       /* If this is for a scalar, just make a VAR_DECL for it.  If for
6253          an aggregate, get a null pointer of the appropriate type and
6254          dereference it.  */
6255       if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
6256         *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
6257                           convert (build_pointer_type (TREE_TYPE (expr)),
6258                                    integer_zero_node));
6259       else
6260         {
6261           *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
6262           TREE_NO_WARNING (*expr_p) = 1;
6263         }
6264
6265       gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
6266       return GS_OK;
6267
6268     case UNCONSTRAINED_ARRAY_REF:
6269       /* We should only do this if we are just elaborating for side-effects,
6270          but we can't know that yet.  */
6271       *expr_p = TREE_OPERAND (*expr_p, 0);
6272       return GS_OK;
6273
6274     case ADDR_EXPR:
6275       op = TREE_OPERAND (expr, 0);
6276
6277       /* If we are taking the address of a constant CONSTRUCTOR, make sure it
6278          is put into static memory.  We know that it's going to be read-only
6279          given the semantics we have and it must be in static memory when the
6280          reference is in an elaboration procedure.  */
6281       if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
6282         {
6283           tree addr = build_fold_addr_expr (tree_output_constant_def (op));
6284           *expr_p = fold_convert (TREE_TYPE (expr), addr);
6285           return GS_ALL_DONE;
6286         }
6287
6288       /* Otherwise, if we are taking the address of a non-constant CONSTRUCTOR
6289          or of a call, explicitly create the local temporary.  That's required
6290          if the type is passed by reference.  */
6291       if (TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
6292         {
6293           tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
6294           TREE_ADDRESSABLE (new_var) = 1;
6295           gimple_add_tmp_var (new_var);
6296
6297           mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
6298           gimplify_and_add (mod, pre_p);
6299
6300           TREE_OPERAND (expr, 0) = new_var;
6301           recompute_tree_invariant_for_addr_expr (expr);
6302           return GS_ALL_DONE;
6303         }
6304
6305       return GS_UNHANDLED;
6306
6307     case DECL_EXPR:
6308       op = DECL_EXPR_DECL (expr);
6309
6310       /* The expressions for the RM bounds must be gimplified to ensure that
6311          they are properly elaborated.  See gimplify_decl_expr.  */
6312       if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
6313           && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
6314         switch (TREE_CODE (TREE_TYPE (op)))
6315           {
6316           case INTEGER_TYPE:
6317           case ENUMERAL_TYPE:
6318           case BOOLEAN_TYPE:
6319           case REAL_TYPE:
6320             {
6321               tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
6322
6323               val = TYPE_RM_MIN_VALUE (type);
6324               if (val)
6325                 {
6326                   gimplify_one_sizepos (&val, pre_p);
6327                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
6328                     SET_TYPE_RM_MIN_VALUE (t, val);
6329                 }
6330
6331               val = TYPE_RM_MAX_VALUE (type);
6332               if (val)
6333                 {
6334                   gimplify_one_sizepos (&val, pre_p);
6335                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
6336                     SET_TYPE_RM_MAX_VALUE (t, val);
6337                 }
6338
6339             }
6340             break;
6341
6342           default:
6343             break;
6344           }
6345
6346       /* ... fall through ... */
6347
6348     default:
6349       return GS_UNHANDLED;
6350     }
6351 }
6352
6353 /* Generate GIMPLE in place for the statement at *STMT_P.  */
6354
6355 static enum gimplify_status
6356 gnat_gimplify_stmt (tree *stmt_p)
6357 {
6358   tree stmt = *stmt_p;
6359
6360   switch (TREE_CODE (stmt))
6361     {
6362     case STMT_STMT:
6363       *stmt_p = STMT_STMT_STMT (stmt);
6364       return GS_OK;
6365
6366     case LOOP_STMT:
6367       {
6368         tree gnu_start_label = create_artificial_label (input_location);
6369         tree gnu_cond = LOOP_STMT_COND (stmt);
6370         tree gnu_update = LOOP_STMT_UPDATE (stmt);
6371         tree gnu_end_label = LOOP_STMT_LABEL (stmt);
6372         tree t;
6373
6374         /* Build the condition expression from the test, if any.  */
6375         if (gnu_cond)
6376           gnu_cond
6377             = build3 (COND_EXPR, void_type_node, gnu_cond, alloc_stmt_list (),
6378                       build1 (GOTO_EXPR, void_type_node, gnu_end_label));
6379
6380         /* Set to emit the statements of the loop.  */
6381         *stmt_p = NULL_TREE;
6382
6383         /* We first emit the start label and then a conditional jump to the
6384            end label if there's a top condition, then the update if it's at
6385            the top, then the body of the loop, then a conditional jump to
6386            the end label if there's a bottom condition, then the update if
6387            it's at the bottom, and finally a jump to the start label and the
6388            definition of the end label.  */
6389         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
6390                                           gnu_start_label),
6391                                   stmt_p);
6392
6393         if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
6394           append_to_statement_list (gnu_cond, stmt_p);
6395
6396         if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
6397           append_to_statement_list (gnu_update, stmt_p);
6398
6399         append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
6400
6401         if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
6402           append_to_statement_list (gnu_cond, stmt_p);
6403
6404         if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
6405           append_to_statement_list (gnu_update, stmt_p);
6406
6407         t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
6408         SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
6409         append_to_statement_list (t, stmt_p);
6410
6411         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
6412                                           gnu_end_label),
6413                                   stmt_p);
6414         return GS_OK;
6415       }
6416
6417     case EXIT_STMT:
6418       /* Build a statement to jump to the corresponding end label, then
6419          see if it needs to be conditional.  */
6420       *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
6421       if (EXIT_STMT_COND (stmt))
6422         *stmt_p = build3 (COND_EXPR, void_type_node,
6423                           EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
6424       return GS_OK;
6425
6426     default:
6427       gcc_unreachable ();
6428     }
6429 }
6430 \f
6431 /* Force references to each of the entities in packages withed by GNAT_NODE.
6432    Operate recursively but check that we aren't elaborating something more
6433    than once.
6434
6435    This routine is exclusively called in type_annotate mode, to compute DDA
6436    information for types in withed units, for ASIS use.  */
6437
6438 static void
6439 elaborate_all_entities (Node_Id gnat_node)
6440 {
6441   Entity_Id gnat_with_clause, gnat_entity;
6442
6443   /* Process each unit only once.  As we trace the context of all relevant
6444      units transitively, including generic bodies, we may encounter the
6445      same generic unit repeatedly.  */
6446   if (!present_gnu_tree (gnat_node))
6447      save_gnu_tree (gnat_node, integer_zero_node, true);
6448
6449   /* Save entities in all context units.  A body may have an implicit_with
6450      on its own spec, if the context includes a child unit, so don't save
6451      the spec twice.  */
6452   for (gnat_with_clause = First (Context_Items (gnat_node));
6453        Present (gnat_with_clause);
6454        gnat_with_clause = Next (gnat_with_clause))
6455     if (Nkind (gnat_with_clause) == N_With_Clause
6456         && !present_gnu_tree (Library_Unit (gnat_with_clause))
6457         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
6458       {
6459         elaborate_all_entities (Library_Unit (gnat_with_clause));
6460
6461         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
6462           {
6463             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
6464                  Present (gnat_entity);
6465                  gnat_entity = Next_Entity (gnat_entity))
6466               if (Is_Public (gnat_entity)
6467                   && Convention (gnat_entity) != Convention_Intrinsic
6468                   && Ekind (gnat_entity) != E_Package
6469                   && Ekind (gnat_entity) != E_Package_Body
6470                   && Ekind (gnat_entity) != E_Operator
6471                   && !(IN (Ekind (gnat_entity), Type_Kind)
6472                        && !Is_Frozen (gnat_entity))
6473                   && !((Ekind (gnat_entity) == E_Procedure
6474                         || Ekind (gnat_entity) == E_Function)
6475                        && Is_Intrinsic_Subprogram (gnat_entity))
6476                   && !IN (Ekind (gnat_entity), Named_Kind)
6477                   && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
6478                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
6479           }
6480         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
6481           {
6482             Node_Id gnat_body
6483               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
6484
6485             /* Retrieve compilation unit node of generic body.  */
6486             while (Present (gnat_body)
6487                    && Nkind (gnat_body) != N_Compilation_Unit)
6488               gnat_body = Parent (gnat_body);
6489
6490             /* If body is available, elaborate its context.  */
6491             if (Present (gnat_body))
6492               elaborate_all_entities (gnat_body);
6493           }
6494       }
6495
6496   if (Nkind (Unit (gnat_node)) == N_Package_Body)
6497     elaborate_all_entities (Library_Unit (gnat_node));
6498 }
6499 \f
6500 /* Do the processing of GNAT_NODE, an N_Freeze_Entity.  */
6501
6502 static void
6503 process_freeze_entity (Node_Id gnat_node)
6504 {
6505   const Entity_Id gnat_entity = Entity (gnat_node);
6506   const Entity_Kind kind = Ekind (gnat_entity);
6507   tree gnu_old, gnu_new;
6508
6509   /* If this is a package, we need to generate code for the package.  */
6510   if (kind == E_Package)
6511     {
6512       insert_code_for
6513         (Parent (Corresponding_Body
6514                  (Parent (Declaration_Node (gnat_entity)))));
6515       return;
6516     }
6517
6518   /* Don't do anything for class-wide types as they are always transformed
6519      into their root type.  */
6520   if (kind == E_Class_Wide_Type)
6521     return;
6522
6523   /* Check for an old definition.  This freeze node might be for an Itype.  */
6524   gnu_old
6525     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
6526
6527   /* If this entity has an address representation clause, GNU_OLD is the
6528      address, so discard it here.  */
6529   if (Present (Address_Clause (gnat_entity)))
6530     gnu_old = NULL_TREE;
6531
6532   /* Don't do anything for subprograms that may have been elaborated before
6533      their freeze nodes.  This can happen, for example, because of an inner
6534      call in an instance body or because of previous compilation of a spec
6535      for inlining purposes.  */
6536   if (gnu_old
6537       && ((TREE_CODE (gnu_old) == FUNCTION_DECL
6538            && (kind == E_Function || kind == E_Procedure))
6539           || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
6540               && kind == E_Subprogram_Type)))
6541     return;
6542
6543   /* If we have a non-dummy type old tree, we have nothing to do, except
6544      aborting if this is the public view of a private type whose full view was
6545      not delayed, as this node was never delayed as it should have been.  We
6546      let this happen for concurrent types and their Corresponding_Record_Type,
6547      however, because each might legitimately be elaborated before its own
6548      freeze node, e.g. while processing the other.  */
6549   if (gnu_old
6550       && !(TREE_CODE (gnu_old) == TYPE_DECL
6551            && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
6552     {
6553       gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
6554                    && Present (Full_View (gnat_entity))
6555                    && No (Freeze_Node (Full_View (gnat_entity))))
6556                   || Is_Concurrent_Type (gnat_entity)
6557                   || (IN (kind, Record_Kind)
6558                       && Is_Concurrent_Record_Type (gnat_entity)));
6559       return;
6560     }
6561
6562   /* Reset the saved tree, if any, and elaborate the object or type for real.
6563      If there is a full view, elaborate it and use the result.  And, if this
6564      is the root type of a class-wide type, reuse it for the latter.  */
6565   if (gnu_old)
6566     {
6567       save_gnu_tree (gnat_entity, NULL_TREE, false);
6568       if (IN (kind, Incomplete_Or_Private_Kind)
6569           && Present (Full_View (gnat_entity))
6570           && present_gnu_tree (Full_View (gnat_entity)))
6571         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
6572       if (IN (kind, Type_Kind)
6573           && Present (Class_Wide_Type (gnat_entity))
6574           && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6575         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
6576     }
6577
6578   if (IN (kind, Incomplete_Or_Private_Kind)
6579       && Present (Full_View (gnat_entity)))
6580     {
6581       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
6582
6583       /* Propagate back-annotations from full view to partial view.  */
6584       if (Unknown_Alignment (gnat_entity))
6585         Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
6586
6587       if (Unknown_Esize (gnat_entity))
6588         Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
6589
6590       if (Unknown_RM_Size (gnat_entity))
6591         Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
6592
6593       /* The above call may have defined this entity (the simplest example
6594          of this is when we have a private enumeral type since the bounds
6595          will have the public view).  */
6596       if (!present_gnu_tree (gnat_entity))
6597         save_gnu_tree (gnat_entity, gnu_new, false);
6598     }
6599   else
6600     {
6601       tree gnu_init
6602         = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
6603            && present_gnu_tree (Declaration_Node (gnat_entity)))
6604           ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
6605
6606       gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
6607     }
6608
6609   if (IN (kind, Type_Kind)
6610       && Present (Class_Wide_Type (gnat_entity))
6611       && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6612     save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
6613
6614   /* If we have an old type and we've made pointers to this type, update those
6615      pointers.  If this is a Taft amendment type in the main unit, we need to
6616      mark the type as used since other units referencing it don't see the full
6617      declaration and, therefore, cannot mark it as used themselves.  */
6618   if (gnu_old)
6619     {
6620       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
6621                          TREE_TYPE (gnu_new));
6622       if (DECL_TAFT_TYPE_P (gnu_old))
6623         used_types_insert (TREE_TYPE (gnu_new));
6624     }
6625 }
6626 \f
6627 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
6628    We make two passes, one to elaborate anything other than bodies (but
6629    we declare a function if there was no spec).  The second pass
6630    elaborates the bodies.
6631
6632    GNAT_END_LIST gives the element in the list past the end.  Normally,
6633    this is Empty, but can be First_Real_Statement for a
6634    Handled_Sequence_Of_Statements.
6635
6636    We make a complete pass through both lists if PASS1P is true, then make
6637    the second pass over both lists if PASS2P is true.  The lists usually
6638    correspond to the public and private parts of a package.  */
6639
6640 static void
6641 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
6642                Node_Id gnat_end_list, bool pass1p, bool pass2p)
6643 {
6644   List_Id gnat_decl_array[2];
6645   Node_Id gnat_decl;
6646   int i;
6647
6648   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
6649
6650   if (pass1p)
6651     for (i = 0; i <= 1; i++)
6652       if (Present (gnat_decl_array[i]))
6653         for (gnat_decl = First (gnat_decl_array[i]);
6654              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6655           {
6656             /* For package specs, we recurse inside the declarations,
6657                thus taking the two pass approach inside the boundary.  */
6658             if (Nkind (gnat_decl) == N_Package_Declaration
6659                 && (Nkind (Specification (gnat_decl)
6660                            == N_Package_Specification)))
6661               process_decls (Visible_Declarations (Specification (gnat_decl)),
6662                              Private_Declarations (Specification (gnat_decl)),
6663                              Empty, true, false);
6664
6665             /* Similarly for any declarations in the actions of a
6666                freeze node.  */
6667             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6668               {
6669                 process_freeze_entity (gnat_decl);
6670                 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
6671               }
6672
6673             /* Package bodies with freeze nodes get their elaboration deferred
6674                until the freeze node, but the code must be placed in the right
6675                place, so record the code position now.  */
6676             else if (Nkind (gnat_decl) == N_Package_Body
6677                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
6678               record_code_position (gnat_decl);
6679
6680             else if (Nkind (gnat_decl) == N_Package_Body_Stub
6681                      && Present (Library_Unit (gnat_decl))
6682                      && Present (Freeze_Node
6683                                  (Corresponding_Spec
6684                                   (Proper_Body (Unit
6685                                                 (Library_Unit (gnat_decl)))))))
6686               record_code_position
6687                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
6688
6689             /* We defer most subprogram bodies to the second pass.  */
6690             else if (Nkind (gnat_decl) == N_Subprogram_Body)
6691               {
6692                 if (Acts_As_Spec (gnat_decl))
6693                   {
6694                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
6695
6696                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
6697                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6698                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6699                   }
6700               }
6701
6702             /* For bodies and stubs that act as their own specs, the entity
6703                itself must be elaborated in the first pass, because it may
6704                be used in other declarations.  */
6705             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
6706               {
6707                 Node_Id gnat_subprog_id
6708                   = Defining_Entity (Specification (gnat_decl));
6709
6710                     if (Ekind (gnat_subprog_id) != E_Subprogram_Body
6711                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
6712                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6713                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6714               }
6715
6716             /* Concurrent stubs stand for the corresponding subprogram bodies,
6717                which are deferred like other bodies.  */
6718             else if (Nkind (gnat_decl) == N_Task_Body_Stub
6719                      || Nkind (gnat_decl) == N_Protected_Body_Stub)
6720               ;
6721
6722             else
6723               add_stmt (gnat_to_gnu (gnat_decl));
6724           }
6725
6726   /* Here we elaborate everything we deferred above except for package bodies,
6727      which are elaborated at their freeze nodes.  Note that we must also
6728      go inside things (package specs and freeze nodes) the first pass did.  */
6729   if (pass2p)
6730     for (i = 0; i <= 1; i++)
6731       if (Present (gnat_decl_array[i]))
6732         for (gnat_decl = First (gnat_decl_array[i]);
6733              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6734           {
6735             if (Nkind (gnat_decl) == N_Subprogram_Body
6736                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
6737                 || Nkind (gnat_decl) == N_Task_Body_Stub
6738                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
6739               add_stmt (gnat_to_gnu (gnat_decl));
6740
6741             else if (Nkind (gnat_decl) == N_Package_Declaration
6742                      && (Nkind (Specification (gnat_decl)
6743                                 == N_Package_Specification)))
6744               process_decls (Visible_Declarations (Specification (gnat_decl)),
6745                              Private_Declarations (Specification (gnat_decl)),
6746                              Empty, false, true);
6747
6748             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6749               process_decls (Actions (gnat_decl), Empty, Empty, false, true);
6750           }
6751 }
6752 \f
6753 /* Make a unary operation of kind CODE using build_unary_op, but guard
6754    the operation by an overflow check.  CODE can be one of NEGATE_EXPR
6755    or ABS_EXPR.  GNU_TYPE is the type desired for the result.  Usually
6756    the operation is to be performed in that type.  GNAT_NODE is the gnat
6757    node conveying the source location for which the error should be
6758    signaled.  */
6759
6760 static tree
6761 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
6762                       Node_Id gnat_node)
6763 {
6764   gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
6765
6766   operand = gnat_protect_expr (operand);
6767
6768   return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
6769                                       operand, TYPE_MIN_VALUE (gnu_type)),
6770                      build_unary_op (code, gnu_type, operand),
6771                      CE_Overflow_Check_Failed, gnat_node);
6772 }
6773
6774 /* Make a binary operation of kind CODE using build_binary_op, but guard
6775    the operation by an overflow check.  CODE can be one of PLUS_EXPR,
6776    MINUS_EXPR or MULT_EXPR.  GNU_TYPE is the type desired for the result.
6777    Usually the operation is to be performed in that type.  GNAT_NODE is
6778    the GNAT node conveying the source location for which the error should
6779    be signaled.  */
6780
6781 static tree
6782 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
6783                        tree right, Node_Id gnat_node)
6784 {
6785   tree lhs = gnat_protect_expr (left);
6786   tree rhs = gnat_protect_expr (right);
6787   tree type_max = TYPE_MAX_VALUE (gnu_type);
6788   tree type_min = TYPE_MIN_VALUE (gnu_type);
6789   tree gnu_expr;
6790   tree tmp1, tmp2;
6791   tree zero = convert (gnu_type, integer_zero_node);
6792   tree rhs_lt_zero;
6793   tree check_pos;
6794   tree check_neg;
6795   tree check;
6796   int precision = TYPE_PRECISION (gnu_type);
6797
6798   gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */
6799
6800   /* Prefer a constant or known-positive rhs to simplify checks.  */
6801   if (!TREE_CONSTANT (rhs)
6802       && commutative_tree_code (code)
6803       && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs)
6804                                   && tree_expr_nonnegative_p (lhs))))
6805     {
6806       tree tmp = lhs;
6807       lhs = rhs;
6808       rhs = tmp;
6809     }
6810
6811   rhs_lt_zero = tree_expr_nonnegative_p (rhs)
6812                 ? boolean_false_node
6813                 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
6814
6815   /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
6816
6817   /* Try a few strategies that may be cheaper than the general
6818      code at the end of the function, if the rhs is not known.
6819      The strategies are:
6820        - Call library function for 64-bit multiplication (complex)
6821        - Widen, if input arguments are sufficiently small
6822        - Determine overflow using wrapped result for addition/subtraction.  */
6823
6824   if (!TREE_CONSTANT (rhs))
6825     {
6826       /* Even for add/subtract double size to get another base type.  */
6827       int needed_precision = precision * 2;
6828
6829       if (code == MULT_EXPR && precision == 64)
6830         {
6831           tree int_64 = gnat_type_for_size (64, 0);
6832
6833           return convert (gnu_type, build_call_2_expr (mulv64_decl,
6834                                                        convert (int_64, lhs),
6835                                                        convert (int_64, rhs)));
6836         }
6837
6838       else if (needed_precision <= BITS_PER_WORD
6839                || (code == MULT_EXPR
6840                    && needed_precision <= LONG_LONG_TYPE_SIZE))
6841         {
6842           tree wide_type = gnat_type_for_size (needed_precision, 0);
6843
6844           tree wide_result = build_binary_op (code, wide_type,
6845                                               convert (wide_type, lhs),
6846                                               convert (wide_type, rhs));
6847
6848           tree check = build_binary_op
6849             (TRUTH_ORIF_EXPR, boolean_type_node,
6850              build_binary_op (LT_EXPR, boolean_type_node, wide_result,
6851                               convert (wide_type, type_min)),
6852              build_binary_op (GT_EXPR, boolean_type_node, wide_result,
6853                               convert (wide_type, type_max)));
6854
6855           tree result = convert (gnu_type, wide_result);
6856
6857           return
6858             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
6859         }
6860
6861       else if (code == PLUS_EXPR || code == MINUS_EXPR)
6862         {
6863           tree unsigned_type = gnat_type_for_size (precision, 1);
6864           tree wrapped_expr = convert
6865             (gnu_type, build_binary_op (code, unsigned_type,
6866                                         convert (unsigned_type, lhs),
6867                                         convert (unsigned_type, rhs)));
6868
6869           tree result = convert
6870             (gnu_type, build_binary_op (code, gnu_type, lhs, rhs));
6871
6872           /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
6873              or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction.  */
6874           tree check = build_binary_op
6875             (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
6876              build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
6877                               boolean_type_node, wrapped_expr, lhs));
6878
6879           return
6880             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
6881         }
6882    }
6883
6884   switch (code)
6885     {
6886     case PLUS_EXPR:
6887       /* When rhs >= 0, overflow when lhs > type_max - rhs.  */
6888       check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
6889                                    build_binary_op (MINUS_EXPR, gnu_type,
6890                                                     type_max, rhs)),
6891
6892       /* When rhs < 0, overflow when lhs < type_min - rhs.  */
6893       check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
6894                                    build_binary_op (MINUS_EXPR, gnu_type,
6895                                                     type_min, rhs));
6896       break;
6897
6898     case MINUS_EXPR:
6899       /* When rhs >= 0, overflow when lhs < type_min + rhs.  */
6900       check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
6901                                    build_binary_op (PLUS_EXPR, gnu_type,
6902                                                     type_min, rhs)),
6903
6904       /* When rhs < 0, overflow when lhs > type_max + rhs.  */
6905       check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
6906                                    build_binary_op (PLUS_EXPR, gnu_type,
6907                                                     type_max, rhs));
6908       break;
6909
6910     case MULT_EXPR:
6911       /* The check here is designed to be efficient if the rhs is constant,
6912          but it will work for any rhs by using integer division.
6913          Four different check expressions determine whether X * C overflows,
6914          depending on C.
6915            C ==  0  =>  false
6916            C  >  0  =>  X > type_max / C || X < type_min / C
6917            C == -1  =>  X == type_min
6918            C  < -1  =>  X > type_min / C || X < type_max / C */
6919
6920       tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
6921       tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
6922
6923       check_pos
6924         = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6925                            build_binary_op (NE_EXPR, boolean_type_node, zero,
6926                                             rhs),
6927                            build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
6928                                             build_binary_op (GT_EXPR,
6929                                                              boolean_type_node,
6930                                                              lhs, tmp1),
6931                                             build_binary_op (LT_EXPR,
6932                                                              boolean_type_node,
6933                                                              lhs, tmp2)));
6934
6935       check_neg
6936         = fold_build3 (COND_EXPR, boolean_type_node,
6937                        build_binary_op (EQ_EXPR, boolean_type_node, rhs,
6938                                         build_int_cst (gnu_type, -1)),
6939                        build_binary_op (EQ_EXPR, boolean_type_node, lhs,
6940                                         type_min),
6941                        build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
6942                                         build_binary_op (GT_EXPR,
6943                                                          boolean_type_node,
6944                                                          lhs, tmp2),
6945                                         build_binary_op (LT_EXPR,
6946                                                          boolean_type_node,
6947                                                          lhs, tmp1)));
6948       break;
6949
6950     default:
6951       gcc_unreachable();
6952     }
6953
6954   gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
6955
6956   /* If we can fold the expression to a constant, just return it.
6957      The caller will deal with overflow, no need to generate a check.  */
6958   if (TREE_CONSTANT (gnu_expr))
6959     return gnu_expr;
6960
6961   check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
6962                        check_pos);
6963
6964   return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
6965 }
6966
6967 /* Emit code for a range check.  GNU_EXPR is the expression to be checked,
6968    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
6969    which we have to check.  GNAT_NODE is the GNAT node conveying the source
6970    location for which the error should be signaled.  */
6971
6972 static tree
6973 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
6974 {
6975   tree gnu_range_type = get_unpadded_type (gnat_range_type);
6976   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
6977   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
6978   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
6979
6980   /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
6981      This can for example happen when translating 'Val or 'Value.  */
6982   if (gnu_compare_type == gnu_range_type)
6983     return gnu_expr;
6984
6985   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
6986      we can't do anything since we might be truncating the bounds.  No
6987      check is needed in this case.  */
6988   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
6989       && (TYPE_PRECISION (gnu_compare_type)
6990           < TYPE_PRECISION (get_base_type (gnu_range_type))))
6991     return gnu_expr;
6992
6993   /* Checked expressions must be evaluated only once.  */
6994   gnu_expr = gnat_protect_expr (gnu_expr);
6995
6996   /* Note that the form of the check is
6997         (not (expr >= lo)) or (not (expr <= hi))
6998      the reason for this slightly convoluted form is that NaNs
6999      are not considered to be in range in the float case.  */
7000   return emit_check
7001     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7002                       invert_truthvalue
7003                       (build_binary_op (GE_EXPR, boolean_type_node,
7004                                        convert (gnu_compare_type, gnu_expr),
7005                                        convert (gnu_compare_type, gnu_low))),
7006                       invert_truthvalue
7007                       (build_binary_op (LE_EXPR, boolean_type_node,
7008                                         convert (gnu_compare_type, gnu_expr),
7009                                         convert (gnu_compare_type,
7010                                                  gnu_high)))),
7011      gnu_expr, CE_Range_Check_Failed, gnat_node);
7012 }
7013 \f
7014 /* Emit code for an index check.  GNU_ARRAY_OBJECT is the array object which
7015    we are about to index, GNU_EXPR is the index expression to be checked,
7016    GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
7017    has to be checked.  Note that for index checking we cannot simply use the
7018    emit_range_check function (although very similar code needs to be generated
7019    in both cases) since for index checking the array type against which we are
7020    checking the indices may be unconstrained and consequently we need to get
7021    the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
7022    The place where we need to do that is in subprograms having unconstrained
7023    array formal parameters.  GNAT_NODE is the GNAT node conveying the source
7024    location for which the error should be signaled.  */
7025
7026 static tree
7027 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
7028                   tree gnu_high, Node_Id gnat_node)
7029 {
7030   tree gnu_expr_check;
7031
7032   /* Checked expressions must be evaluated only once.  */
7033   gnu_expr = gnat_protect_expr (gnu_expr);
7034
7035   /* Must do this computation in the base type in case the expression's
7036      type is an unsigned subtypes.  */
7037   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
7038
7039   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
7040      the object we are handling.  */
7041   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
7042   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
7043
7044   return emit_check
7045     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7046                       build_binary_op (LT_EXPR, boolean_type_node,
7047                                        gnu_expr_check,
7048                                        convert (TREE_TYPE (gnu_expr_check),
7049                                                 gnu_low)),
7050                       build_binary_op (GT_EXPR, boolean_type_node,
7051                                        gnu_expr_check,
7052                                        convert (TREE_TYPE (gnu_expr_check),
7053                                                 gnu_high))),
7054      gnu_expr, CE_Index_Check_Failed, gnat_node);
7055 }
7056 \f
7057 /* GNU_COND contains the condition corresponding to an access, discriminant or
7058    range check of value GNU_EXPR.  Build a COND_EXPR that returns GNU_EXPR if
7059    GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
7060    REASON is the code that says why the exception was raised.  GNAT_NODE is
7061    the GNAT node conveying the source location for which the error should be
7062    signaled.  */
7063
7064 static tree
7065 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
7066 {
7067   tree gnu_call
7068     = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
7069   tree gnu_result
7070     = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
7071                    build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
7072                            convert (TREE_TYPE (gnu_expr), integer_zero_node)),
7073                    gnu_expr);
7074
7075   /* GNU_RESULT has side effects if and only if GNU_EXPR has:
7076      we don't need to evaluate it just for the check.  */
7077   TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
7078
7079   return gnu_result;
7080 }
7081 \f
7082 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
7083    checks if OVERFLOW_P is true and range checks if RANGE_P is true.
7084    GNAT_TYPE is known to be an integral type.  If TRUNCATE_P true, do a
7085    float to integer conversion with truncation; otherwise round.
7086    GNAT_NODE is the GNAT node conveying the source location for which the
7087    error should be signaled.  */
7088
7089 static tree
7090 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
7091                     bool rangep, bool truncatep, Node_Id gnat_node)
7092 {
7093   tree gnu_type = get_unpadded_type (gnat_type);
7094   tree gnu_in_type = TREE_TYPE (gnu_expr);
7095   tree gnu_in_basetype = get_base_type (gnu_in_type);
7096   tree gnu_base_type = get_base_type (gnu_type);
7097   tree gnu_result = gnu_expr;
7098
7099   /* If we are not doing any checks, the output is an integral type, and
7100      the input is not a floating type, just do the conversion.  This
7101      shortcut is required to avoid problems with packed array types
7102      and simplifies code in all cases anyway.   */
7103   if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
7104       && !FLOAT_TYPE_P (gnu_in_type))
7105     return convert (gnu_type, gnu_expr);
7106
7107   /* First convert the expression to its base type.  This
7108      will never generate code, but makes the tests below much simpler.
7109      But don't do this if converting from an integer type to an unconstrained
7110      array type since then we need to get the bounds from the original
7111      (unpacked) type.  */
7112   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
7113     gnu_result = convert (gnu_in_basetype, gnu_result);
7114
7115   /* If overflow checks are requested,  we need to be sure the result will
7116      fit in the output base type.  But don't do this if the input
7117      is integer and the output floating-point.  */
7118   if (overflowp
7119       && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
7120     {
7121       /* Ensure GNU_EXPR only gets evaluated once.  */
7122       tree gnu_input = gnat_protect_expr (gnu_result);
7123       tree gnu_cond = integer_zero_node;
7124       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
7125       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
7126       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
7127       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
7128
7129       /* Convert the lower bounds to signed types, so we're sure we're
7130          comparing them properly.  Likewise, convert the upper bounds
7131          to unsigned types.  */
7132       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
7133         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
7134
7135       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7136           && !TYPE_UNSIGNED (gnu_in_basetype))
7137         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
7138
7139       if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
7140         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
7141
7142       if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
7143         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
7144
7145       /* Check each bound separately and only if the result bound
7146          is tighter than the bound on the input type.  Note that all the
7147          types are base types, so the bounds must be constant. Also,
7148          the comparison is done in the base type of the input, which
7149          always has the proper signedness.  First check for input
7150          integer (which means output integer), output float (which means
7151          both float), or mixed, in which case we always compare.
7152          Note that we have to do the comparison which would *fail* in the
7153          case of an error since if it's an FP comparison and one of the
7154          values is a NaN or Inf, the comparison will fail.  */
7155       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7156           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
7157           : (FLOAT_TYPE_P (gnu_base_type)
7158              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
7159                                  TREE_REAL_CST (gnu_out_lb))
7160              : 1))
7161         gnu_cond
7162           = invert_truthvalue
7163             (build_binary_op (GE_EXPR, boolean_type_node,
7164                               gnu_input, convert (gnu_in_basetype,
7165                                                   gnu_out_lb)));
7166
7167       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7168           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
7169           : (FLOAT_TYPE_P (gnu_base_type)
7170              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
7171                                  TREE_REAL_CST (gnu_in_lb))
7172              : 1))
7173         gnu_cond
7174           = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
7175                              invert_truthvalue
7176                              (build_binary_op (LE_EXPR, boolean_type_node,
7177                                                gnu_input,
7178                                                convert (gnu_in_basetype,
7179                                                         gnu_out_ub))));
7180
7181       if (!integer_zerop (gnu_cond))
7182         gnu_result = emit_check (gnu_cond, gnu_input,
7183                                  CE_Overflow_Check_Failed, gnat_node);
7184     }
7185
7186   /* Now convert to the result base type.  If this is a non-truncating
7187      float-to-integer conversion, round.  */
7188   if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
7189       && !truncatep)
7190     {
7191       REAL_VALUE_TYPE half_minus_pred_half, pred_half;
7192       tree gnu_conv, gnu_zero, gnu_comp, calc_type;
7193       tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
7194       const struct real_format *fmt;
7195
7196       /* The following calculations depend on proper rounding to even
7197          of each arithmetic operation. In order to prevent excess
7198          precision from spoiling this property, use the widest hardware
7199          floating-point type if FP_ARITH_MAY_WIDEN is true.  */
7200       calc_type
7201         = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
7202
7203       /* FIXME: Should not have padding in the first place.  */
7204       if (TYPE_IS_PADDING_P (calc_type))
7205         calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
7206
7207       /* Compute the exact value calc_type'Pred (0.5) at compile time.  */
7208       fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
7209       real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
7210       REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
7211                        half_minus_pred_half);
7212       gnu_pred_half = build_real (calc_type, pred_half);
7213
7214       /* If the input is strictly negative, subtract this value
7215          and otherwise add it from the input.  For 0.5, the result
7216          is exactly between 1.0 and the machine number preceding 1.0
7217          (for calc_type).  Since the last bit of 1.0 is even, this 0.5
7218          will round to 1.0, while all other number with an absolute
7219          value less than 0.5 round to 0.0.  For larger numbers exactly
7220          halfway between integers, rounding will always be correct as
7221          the true mathematical result will be closer to the higher
7222          integer compared to the lower one.  So, this constant works
7223          for all floating-point numbers.
7224
7225          The reason to use the same constant with subtract/add instead
7226          of a positive and negative constant is to allow the comparison
7227          to be scheduled in parallel with retrieval of the constant and
7228          conversion of the input to the calc_type (if necessary).  */
7229
7230       gnu_zero = convert (gnu_in_basetype, integer_zero_node);
7231       gnu_result = gnat_protect_expr (gnu_result);
7232       gnu_conv = convert (calc_type, gnu_result);
7233       gnu_comp
7234         = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
7235       gnu_add_pred_half
7236         = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
7237       gnu_subtract_pred_half
7238         = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
7239       gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
7240                                 gnu_add_pred_half, gnu_subtract_pred_half);
7241     }
7242
7243   if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
7244       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
7245       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
7246     gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
7247   else
7248     gnu_result = convert (gnu_base_type, gnu_result);
7249
7250   /* Finally, do the range check if requested.  Note that if the result type
7251      is a modular type, the range check is actually an overflow check.  */
7252   if (rangep
7253       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
7254           && TYPE_MODULAR_P (gnu_base_type) && overflowp))
7255     gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
7256
7257   return convert (gnu_type, gnu_result);
7258 }
7259 \f
7260 /* Return true if GNU_EXPR can be directly addressed.  This is the case
7261    unless it is an expression involving computation or if it involves a
7262    reference to a bitfield or to an object not sufficiently aligned for
7263    its type.  If GNU_TYPE is non-null, return true only if GNU_EXPR can
7264    be directly addressed as an object of this type.
7265
7266    *** Notes on addressability issues in the Ada compiler ***
7267
7268    This predicate is necessary in order to bridge the gap between Gigi
7269    and the middle-end about addressability of GENERIC trees.  A tree
7270    is said to be addressable if it can be directly addressed, i.e. if
7271    its address can be taken, is a multiple of the type's alignment on
7272    strict-alignment architectures and returns the first storage unit
7273    assigned to the object represented by the tree.
7274
7275    In the C family of languages, everything is in practice addressable
7276    at the language level, except for bit-fields.  This means that these
7277    compilers will take the address of any tree that doesn't represent
7278    a bit-field reference and expect the result to be the first storage
7279    unit assigned to the object.  Even in cases where this will result
7280    in unaligned accesses at run time, nothing is supposed to be done
7281    and the program is considered as erroneous instead (see PR c/18287).
7282
7283    The implicit assumptions made in the middle-end are in keeping with
7284    the C viewpoint described above:
7285      - the address of a bit-field reference is supposed to be never
7286        taken; the compiler (generally) will stop on such a construct,
7287      - any other tree is addressable if it is formally addressable,
7288        i.e. if it is formally allowed to be the operand of ADDR_EXPR.
7289
7290    In Ada, the viewpoint is the opposite one: nothing is addressable
7291    at the language level unless explicitly declared so.  This means
7292    that the compiler will both make sure that the trees representing
7293    references to addressable ("aliased" in Ada parlance) objects are
7294    addressable and make no real attempts at ensuring that the trees
7295    representing references to non-addressable objects are addressable.
7296
7297    In the first case, Ada is effectively equivalent to C and handing
7298    down the direct result of applying ADDR_EXPR to these trees to the
7299    middle-end works flawlessly.  In the second case, Ada cannot afford
7300    to consider the program as erroneous if the address of trees that
7301    are not addressable is requested for technical reasons, unlike C;
7302    as a consequence, the Ada compiler must arrange for either making
7303    sure that this address is not requested in the middle-end or for
7304    compensating by inserting temporaries if it is requested in Gigi.
7305
7306    The first goal can be achieved because the middle-end should not
7307    request the address of non-addressable trees on its own; the only
7308    exception is for the invocation of low-level block operations like
7309    memcpy, for which the addressability requirements are lower since
7310    the type's alignment can be disregarded.  In practice, this means
7311    that Gigi must make sure that such operations cannot be applied to
7312    non-BLKmode bit-fields.
7313
7314    The second goal is achieved by means of the addressable_p predicate,
7315    which computes whether a temporary must be inserted by Gigi when the
7316    address of a tree is requested; if so, the address of the temporary
7317    will be used in lieu of that of the original tree and some glue code
7318    generated to connect everything together.  */
7319
7320 static bool
7321 addressable_p (tree gnu_expr, tree gnu_type)
7322 {
7323   /* For an integral type, the size of the actual type of the object may not
7324      be greater than that of the expected type, otherwise an indirect access
7325      in the latter type wouldn't correctly set all the bits of the object.  */
7326   if (gnu_type
7327       && INTEGRAL_TYPE_P (gnu_type)
7328       && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
7329     return false;
7330
7331   /* The size of the actual type of the object may not be smaller than that
7332      of the expected type, otherwise an indirect access in the latter type
7333      would be larger than the object.  But only record types need to be
7334      considered in practice for this case.  */
7335   if (gnu_type
7336       && TREE_CODE (gnu_type) == RECORD_TYPE
7337       && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
7338     return false;
7339
7340   switch (TREE_CODE (gnu_expr))
7341     {
7342     case VAR_DECL:
7343     case PARM_DECL:
7344     case FUNCTION_DECL:
7345     case RESULT_DECL:
7346       /* All DECLs are addressable: if they are in a register, we can force
7347          them to memory.  */
7348       return true;
7349
7350     case UNCONSTRAINED_ARRAY_REF:
7351     case INDIRECT_REF:
7352       /* Taking the address of a dereference yields the original pointer.  */
7353       return true;
7354
7355     case STRING_CST:
7356     case INTEGER_CST:
7357       /* Taking the address yields a pointer to the constant pool.  */
7358       return true;
7359
7360     case CONSTRUCTOR:
7361       /* Taking the address of a static constructor yields a pointer to the
7362          tree constant pool.  */
7363       return TREE_STATIC (gnu_expr) ? true : false;
7364
7365     case NULL_EXPR:
7366     case SAVE_EXPR:
7367     case CALL_EXPR:
7368     case PLUS_EXPR:
7369     case MINUS_EXPR:
7370     case BIT_IOR_EXPR:
7371     case BIT_XOR_EXPR:
7372     case BIT_AND_EXPR:
7373     case BIT_NOT_EXPR:
7374       /* All rvalues are deemed addressable since taking their address will
7375          force a temporary to be created by the middle-end.  */
7376       return true;
7377
7378     case COMPOUND_EXPR:
7379       /* The address of a compound expression is that of its 2nd operand.  */
7380       return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
7381
7382     case COND_EXPR:
7383       /* We accept &COND_EXPR as soon as both operands are addressable and
7384          expect the outcome to be the address of the selected operand.  */
7385       return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
7386               && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
7387
7388     case COMPONENT_REF:
7389       return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
7390                 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
7391                    the field is sufficiently aligned, in case it is subject
7392                    to a pragma Component_Alignment.  But we don't need to
7393                    check the alignment of the containing record, as it is
7394                    guaranteed to be not smaller than that of its most
7395                    aligned field that is not a bit-field.  */
7396                 && (!STRICT_ALIGNMENT
7397                     || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
7398                        >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
7399                /* The field of a padding record is always addressable.  */
7400                || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
7401               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7402
7403     case ARRAY_REF:  case ARRAY_RANGE_REF:
7404     case REALPART_EXPR:  case IMAGPART_EXPR:
7405     case NOP_EXPR:
7406       return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
7407
7408     case CONVERT_EXPR:
7409       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
7410               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7411
7412     case VIEW_CONVERT_EXPR:
7413       {
7414         /* This is addressable if we can avoid a copy.  */
7415         tree type = TREE_TYPE (gnu_expr);
7416         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
7417         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
7418                   && (!STRICT_ALIGNMENT
7419                       || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7420                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
7421                  || ((TYPE_MODE (type) == BLKmode
7422                       || TYPE_MODE (inner_type) == BLKmode)
7423                      && (!STRICT_ALIGNMENT
7424                          || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7425                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
7426                          || TYPE_ALIGN_OK (type)
7427                          || TYPE_ALIGN_OK (inner_type))))
7428                 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7429       }
7430
7431     default:
7432       return false;
7433     }
7434 }
7435 \f
7436 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
7437    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
7438    make a GCC type for GNAT_ENTITY and set up the correspondence.  */
7439
7440 void
7441 process_type (Entity_Id gnat_entity)
7442 {
7443   tree gnu_old
7444     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
7445   tree gnu_new;
7446
7447   /* If we are to delay elaboration of this type, just do any
7448      elaborations needed for expressions within the declaration and
7449      make a dummy type entry for this node and its Full_View (if
7450      any) in case something points to it.  Don't do this if it
7451      has already been done (the only way that can happen is if
7452      the private completion is also delayed).  */
7453   if (Present (Freeze_Node (gnat_entity))
7454       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7455           && Present (Full_View (gnat_entity))
7456           && Freeze_Node (Full_View (gnat_entity))
7457           && !present_gnu_tree (Full_View (gnat_entity))))
7458     {
7459       elaborate_entity (gnat_entity);
7460
7461       if (!gnu_old)
7462         {
7463           tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
7464           save_gnu_tree (gnat_entity, gnu_decl, false);
7465           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7466               && Present (Full_View (gnat_entity)))
7467             {
7468               if (Has_Completion_In_Body (gnat_entity))
7469                 DECL_TAFT_TYPE_P (gnu_decl) = 1;
7470               save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
7471             }
7472         }
7473
7474       return;
7475     }
7476
7477   /* If we saved away a dummy type for this node it means that this
7478      made the type that corresponds to the full type of an incomplete
7479      type.  Clear that type for now and then update the type in the
7480      pointers.  */
7481   if (gnu_old)
7482     {
7483       gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
7484                   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
7485
7486       save_gnu_tree (gnat_entity, NULL_TREE, false);
7487     }
7488
7489   /* Now fully elaborate the type.  */
7490   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
7491   gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
7492
7493   /* If we have an old type and we've made pointers to this type, update those
7494      pointers.  If this is a Taft amendment type in the main unit, we need to
7495      mark the type as used since other units referencing it don't see the full
7496      declaration and, therefore, cannot mark it as used themselves.  */
7497   if (gnu_old)
7498     {
7499       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
7500                          TREE_TYPE (gnu_new));
7501       if (DECL_TAFT_TYPE_P (gnu_old))
7502         used_types_insert (TREE_TYPE (gnu_new));
7503     }
7504
7505   /* If this is a record type corresponding to a task or protected type
7506      that is a completion of an incomplete type, perform a similar update
7507      on the type.  ??? Including protected types here is a guess.  */
7508   if (IN (Ekind (gnat_entity), Record_Kind)
7509       && Is_Concurrent_Record_Type (gnat_entity)
7510       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
7511     {
7512       tree gnu_task_old
7513         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
7514
7515       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7516                      NULL_TREE, false);
7517       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7518                      gnu_new, false);
7519
7520       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
7521                          TREE_TYPE (gnu_new));
7522     }
7523 }
7524 \f
7525 /* GNAT_ENTITY is the type of the resulting constructors,
7526    GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
7527    and GNU_TYPE is the GCC type of the corresponding record.
7528
7529    Return a CONSTRUCTOR to build the record.  */
7530
7531 static tree
7532 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
7533 {
7534   tree gnu_list, gnu_result;
7535
7536   /* We test for GNU_FIELD being empty in the case where a variant
7537      was the last thing since we don't take things off GNAT_ASSOC in
7538      that case.  We check GNAT_ASSOC in case we have a variant, but it
7539      has no fields.  */
7540
7541   for (gnu_list = NULL_TREE; Present (gnat_assoc);
7542        gnat_assoc = Next (gnat_assoc))
7543     {
7544       Node_Id gnat_field = First (Choices (gnat_assoc));
7545       tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
7546       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
7547
7548       /* The expander is supposed to put a single component selector name
7549          in every record component association.  */
7550       gcc_assert (No (Next (gnat_field)));
7551
7552       /* Ignore fields that have Corresponding_Discriminants since we'll
7553          be setting that field in the parent.  */
7554       if (Present (Corresponding_Discriminant (Entity (gnat_field)))
7555           && Is_Tagged_Type (Scope (Entity (gnat_field))))
7556         continue;
7557
7558       /* Also ignore discriminants of Unchecked_Unions.  */
7559       else if (Is_Unchecked_Union (gnat_entity)
7560                && Ekind (Entity (gnat_field)) == E_Discriminant)
7561         continue;
7562
7563       /* Before assigning a value in an aggregate make sure range checks
7564          are done if required.  Then convert to the type of the field.  */
7565       if (Do_Range_Check (Expression (gnat_assoc)))
7566         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
7567
7568       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
7569
7570       /* Add the field and expression to the list.  */
7571       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
7572     }
7573
7574   gnu_result = extract_values (gnu_list, gnu_type);
7575
7576 #ifdef ENABLE_CHECKING
7577   {
7578     tree gnu_field;
7579
7580     /* Verify every entry in GNU_LIST was used.  */
7581     for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
7582       gcc_assert (TREE_ADDRESSABLE (gnu_field));
7583   }
7584 #endif
7585
7586   return gnu_result;
7587 }
7588
7589 /* Build a possibly nested constructor for array aggregates.  GNAT_EXPR is
7590    the first element of an array aggregate.  It may itself be an aggregate.
7591    GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
7592    GNAT_COMPONENT_TYPE is the type of the array component; it is needed
7593    for range checking.  */
7594
7595 static tree
7596 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
7597                     Entity_Id gnat_component_type)
7598 {
7599   tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
7600   tree gnu_expr;
7601   VEC(constructor_elt,gc) *gnu_expr_vec = NULL;
7602
7603   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
7604     {
7605       /* If the expression is itself an array aggregate then first build the
7606          innermost constructor if it is part of our array (multi-dimensional
7607          case).  */
7608       if (Nkind (gnat_expr) == N_Aggregate
7609           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
7610           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
7611         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
7612                                        TREE_TYPE (gnu_array_type),
7613                                        gnat_component_type);
7614       else
7615         {
7616           gnu_expr = gnat_to_gnu (gnat_expr);
7617
7618           /* Before assigning the element to the array, make sure it is
7619              in range.  */
7620           if (Do_Range_Check (gnat_expr))
7621             gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
7622         }
7623
7624       CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
7625                               convert (TREE_TYPE (gnu_array_type), gnu_expr));
7626
7627       gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
7628     }
7629
7630   return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
7631 }
7632 \f
7633 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
7634    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
7635    of the associations that are from RECORD_TYPE.  If we see an internal
7636    record, make a recursive call to fill it in as well.  */
7637
7638 static tree
7639 extract_values (tree values, tree record_type)
7640 {
7641   tree field, tem;
7642   VEC(constructor_elt,gc) *v = NULL;
7643
7644   for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
7645     {
7646       tree value = 0;
7647
7648       /* _Parent is an internal field, but may have values in the aggregate,
7649          so check for values first.  */
7650       if ((tem = purpose_member (field, values)))
7651         {
7652           value = TREE_VALUE (tem);
7653           TREE_ADDRESSABLE (tem) = 1;
7654         }
7655
7656       else if (DECL_INTERNAL_P (field))
7657         {
7658           value = extract_values (values, TREE_TYPE (field));
7659           if (TREE_CODE (value) == CONSTRUCTOR
7660               && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
7661             value = 0;
7662         }
7663       else
7664         /* If we have a record subtype, the names will match, but not the
7665            actual FIELD_DECLs.  */
7666         for (tem = values; tem; tem = TREE_CHAIN (tem))
7667           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
7668             {
7669               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
7670               TREE_ADDRESSABLE (tem) = 1;
7671             }
7672
7673       if (!value)
7674         continue;
7675
7676       CONSTRUCTOR_APPEND_ELT (v, field, value);
7677     }
7678
7679   return gnat_build_constructor (record_type, v);
7680 }
7681 \f
7682 /* EXP is to be treated as an array or record.  Handle the cases when it is
7683    an access object and perform the required dereferences.  */
7684
7685 static tree
7686 maybe_implicit_deref (tree exp)
7687 {
7688   /* If the type is a pointer, dereference it.  */
7689   if (POINTER_TYPE_P (TREE_TYPE (exp))
7690       || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
7691     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
7692
7693   /* If we got a padded type, remove it too.  */
7694   if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
7695     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
7696
7697   return exp;
7698 }
7699 \f
7700 /* Convert SLOC into LOCUS.  Return true if SLOC corresponds to a source code
7701    location and false if it doesn't.  In the former case, set the Gigi global
7702    variable REF_FILENAME to the simple debug file name as given by sinput.  */
7703
7704 bool
7705 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
7706 {
7707   if (Sloc == No_Location)
7708     return false;
7709
7710   if (Sloc <= Standard_Location)
7711     {
7712       *locus = BUILTINS_LOCATION;
7713       return false;
7714     }
7715   else
7716     {
7717       Source_File_Index file = Get_Source_File_Index (Sloc);
7718       Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
7719       Column_Number column = Get_Column_Number (Sloc);
7720       struct line_map *map = &line_table->maps[file - 1];
7721
7722       /* Translate the location according to the line-map.h formula.  */
7723       *locus = map->start_location
7724                 + ((line - map->to_line) << map->column_bits)
7725                 + (column & ((1 << map->column_bits) - 1));
7726     }
7727
7728   ref_filename
7729     = IDENTIFIER_POINTER
7730       (get_identifier
7731        (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
7732
7733   return true;
7734 }
7735
7736 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
7737    don't do anything if it doesn't correspond to a source location.  */
7738
7739 static void
7740 set_expr_location_from_node (tree node, Node_Id gnat_node)
7741 {
7742   location_t locus;
7743
7744   if (!Sloc_to_locus (Sloc (gnat_node), &locus))
7745     return;
7746
7747   SET_EXPR_LOCATION (node, locus);
7748 }
7749
7750 /* More elaborate version of set_expr_location_from_node to be used in more
7751    general contexts, for example the result of the translation of a generic
7752    GNAT node.  */
7753
7754 static void
7755 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
7756 {
7757   /* Set the location information on the node if it is a real expression.
7758      References can be reused for multiple GNAT nodes and they would get
7759      the location information of their last use.  Also make sure not to
7760      overwrite an existing location as it is probably more precise.  */
7761
7762   switch (TREE_CODE (node))
7763     {
7764     CASE_CONVERT:
7765     case NON_LVALUE_EXPR:
7766       break;
7767
7768     case COMPOUND_EXPR:
7769       if (EXPR_P (TREE_OPERAND (node, 1)))
7770         set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
7771
7772       /* ... fall through ... */
7773
7774     default:
7775       if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
7776         {
7777           set_expr_location_from_node (node, gnat_node);
7778           set_end_locus_from_node (node, gnat_node);
7779         }
7780       break;
7781     }
7782 }
7783 \f
7784 /* Return a colon-separated list of encodings contained in encoded Ada
7785    name.  */
7786
7787 static const char *
7788 extract_encoding (const char *name)
7789 {
7790   char *encoding = (char *) ggc_alloc_atomic (strlen (name));
7791   get_encoding (name, encoding);
7792   return encoding;
7793 }
7794
7795 /* Extract the Ada name from an encoded name.  */
7796
7797 static const char *
7798 decode_name (const char *name)
7799 {
7800   char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
7801   __gnat_decode (name, decoded, 0);
7802   return decoded;
7803 }
7804 \f
7805 /* Post an error message.  MSG is the error message, properly annotated.
7806    NODE is the node at which to post the error and the node to use for the
7807    '&' substitution.  */
7808
7809 void
7810 post_error (const char *msg, Node_Id node)
7811 {
7812   String_Template temp;
7813   Fat_Pointer fp;
7814
7815   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7816   fp.Array = msg, fp.Bounds = &temp;
7817   if (Present (node))
7818     Error_Msg_N (fp, node);
7819 }
7820
7821 /* Similar to post_error, but NODE is the node at which to post the error and
7822    ENT is the node to use for the '&' substitution.  */
7823
7824 void
7825 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
7826 {
7827   String_Template temp;
7828   Fat_Pointer fp;
7829
7830   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7831   fp.Array = msg, fp.Bounds = &temp;
7832   if (Present (node))
7833     Error_Msg_NE (fp, node, ent);
7834 }
7835
7836 /* Similar to post_error_ne, but NUM is the number to use for the '^'.  */
7837
7838 void
7839 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
7840 {
7841   Error_Msg_Uint_1 = UI_From_Int (num);
7842   post_error_ne (msg, node, ent);
7843 }
7844
7845 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
7846    location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
7847    most sense.  Return true if a sensible assignment was performed.  */
7848
7849 static bool
7850 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
7851 {
7852   Node_Id gnat_end_label = Empty;
7853   location_t end_locus;
7854
7855   /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
7856      end_locus when there is one.  We consider only GNAT nodes with a possible
7857      End_Label attached.  If the End_Label actually was unassigned, fallback
7858      on the orginal node.  We'd better assign an explicit sloc associated with
7859      the outer construct in any case.  */
7860
7861   switch (Nkind (gnat_node))
7862     {
7863     case N_Package_Body:
7864     case N_Subprogram_Body:
7865     case N_Block_Statement:
7866       gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
7867       break;
7868
7869     case N_Package_Declaration:
7870       gnat_end_label = End_Label (Specification (gnat_node));
7871       break;
7872
7873     default:
7874       return false;
7875     }
7876
7877   gnat_node = Present (gnat_end_label) ? gnat_end_label : gnat_node;
7878
7879   /* Some expanded subprograms have neither an End_Label nor a Sloc
7880      attached.  Notify that to callers.  */
7881
7882   if (!Sloc_to_locus (Sloc (gnat_node), &end_locus))
7883     return false;
7884
7885   switch (TREE_CODE (gnu_node))
7886     {
7887     case BIND_EXPR:
7888       BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
7889       return true;
7890
7891     case FUNCTION_DECL:
7892       DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
7893       return true;
7894
7895     default:
7896       return false;
7897     }
7898 }
7899 \f
7900 /* Similar to post_error_ne, but T is a GCC tree representing the number to
7901    write.  If T represents a constant, the text inside curly brackets in
7902    MSG will be output (presumably including a '^').  Otherwise it will not
7903    be output and the text inside square brackets will be output instead.  */
7904
7905 void
7906 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
7907 {
7908   char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
7909   char start_yes, end_yes, start_no, end_no;
7910   const char *p;
7911   char *q;
7912
7913   if (TREE_CODE (t) == INTEGER_CST)
7914     {
7915       Error_Msg_Uint_1 = UI_From_gnu (t);
7916       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
7917     }
7918   else
7919     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
7920
7921   for (p = msg, q = new_msg; *p; p++)
7922     {
7923       if (*p == start_yes)
7924         for (p++; *p != end_yes; p++)
7925           *q++ = *p;
7926       else if (*p == start_no)
7927         for (p++; *p != end_no; p++)
7928           ;
7929       else
7930         *q++ = *p;
7931     }
7932
7933   *q = 0;
7934
7935   post_error_ne (new_msg, node, ent);
7936 }
7937
7938 /* Similar to post_error_ne_tree, but NUM is a second integer to write.  */
7939
7940 void
7941 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
7942                       int num)
7943 {
7944   Error_Msg_Uint_2 = UI_From_Int (num);
7945   post_error_ne_tree (msg, node, ent, t);
7946 }
7947 \f
7948 /* Initialize the table that maps GNAT codes to GCC codes for simple
7949    binary and unary operations.  */
7950
7951 static void
7952 init_code_table (void)
7953 {
7954   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
7955   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
7956
7957   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
7958   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
7959   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
7960   gnu_codes[N_Op_Eq] = EQ_EXPR;
7961   gnu_codes[N_Op_Ne] = NE_EXPR;
7962   gnu_codes[N_Op_Lt] = LT_EXPR;
7963   gnu_codes[N_Op_Le] = LE_EXPR;
7964   gnu_codes[N_Op_Gt] = GT_EXPR;
7965   gnu_codes[N_Op_Ge] = GE_EXPR;
7966   gnu_codes[N_Op_Add] = PLUS_EXPR;
7967   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
7968   gnu_codes[N_Op_Multiply] = MULT_EXPR;
7969   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
7970   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
7971   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
7972   gnu_codes[N_Op_Abs] = ABS_EXPR;
7973   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
7974   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
7975   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
7976   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
7977   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
7978   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
7979 }
7980
7981 /* Return a label to branch to for the exception type in KIND or NULL_TREE
7982    if none.  */
7983
7984 tree
7985 get_exception_label (char kind)
7986 {
7987   if (kind == N_Raise_Constraint_Error)
7988     return VEC_last (tree, gnu_constraint_error_label_stack);
7989   else if (kind == N_Raise_Storage_Error)
7990     return VEC_last (tree, gnu_storage_error_label_stack);
7991   else if (kind == N_Raise_Program_Error)
7992     return VEC_last (tree, gnu_program_error_label_stack);
7993   else
7994     return NULL_TREE;
7995 }
7996
7997 /* Return the decl for the current elaboration procedure.  */
7998
7999 tree
8000 get_elaboration_procedure (void)
8001 {
8002   return VEC_last (tree, gnu_elab_proc_stack);
8003 }
8004
8005 #include "gt-ada-trans.h"