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