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
5798         if (type_annotate_only)
5799           {
5800             gnu_result = alloc_stmt_list ();
5801             break;
5802           }
5803
5804         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5805
5806         if (Exception_Extra_Info
5807             && !No_Exception_Handlers_Set ()
5808             && !get_exception_label (kind)
5809             && VOID_TYPE_P (gnu_result_type)
5810             && Present (cond))
5811           switch (reason)
5812             {
5813             case CE_Access_Check_Failed:
5814               gnu_result = build_call_raise_column (reason, gnat_node);
5815               break;
5816
5817             case CE_Index_Check_Failed:
5818             case CE_Range_Check_Failed:
5819             case CE_Invalid_Data:
5820               if (Nkind (cond) == N_Op_Not
5821                   && Nkind (Right_Opnd (cond)) == N_In
5822                   && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range)
5823                 {
5824                   Node_Id op = Right_Opnd (cond);  /* N_In node */
5825                   Node_Id index = Left_Opnd (op);
5826                   Node_Id range = Right_Opnd (op);
5827                   Node_Id type = Etype (index);
5828                   if (Is_Type (type)
5829                       && Known_Esize (type)
5830                       && UI_To_Int (Esize (type)) <= 32)
5831                     gnu_result
5832                       = build_call_raise_range (reason, gnat_node,
5833                                                 gnat_to_gnu (index),
5834                                                 gnat_to_gnu
5835                                                 (Low_Bound (range)),
5836                                                 gnat_to_gnu
5837                                                 (High_Bound (range)));
5838                 }
5839               break;
5840
5841             default:
5842               break;
5843           }
5844
5845         if (gnu_result == error_mark_node)
5846           gnu_result = build_call_raise (reason, gnat_node, kind);
5847
5848         set_expr_location_from_node (gnu_result, gnat_node);
5849
5850         /* If the type is VOID, this is a statement, so we need to generate
5851            the code for the call.  Handle a condition, if there is one.  */
5852         if (VOID_TYPE_P (gnu_result_type))
5853           {
5854             if (Present (cond))
5855               gnu_result
5856                 = build3 (COND_EXPR, void_type_node, gnat_to_gnu (cond),
5857                           gnu_result, alloc_stmt_list ());
5858           }
5859         else
5860           gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
5861       }
5862       break;
5863
5864     case N_Validate_Unchecked_Conversion:
5865       {
5866         Entity_Id gnat_target_type = Target_Type (gnat_node);
5867         tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
5868         tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
5869
5870         /* No need for any warning in this case.  */
5871         if (!flag_strict_aliasing)
5872           ;
5873
5874         /* If the result is a pointer type, see if we are either converting
5875            from a non-pointer or from a pointer to a type with a different
5876            alias set and warn if so.  If the result is defined in the same
5877            unit as this unchecked conversion, we can allow this because we
5878            can know to make the pointer type behave properly.  */
5879         else if (POINTER_TYPE_P (gnu_target_type)
5880                  && !In_Same_Source_Unit (gnat_target_type, gnat_node)
5881                  && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
5882           {
5883             tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
5884                                          ? TREE_TYPE (gnu_source_type)
5885                                          : NULL_TREE;
5886             tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
5887
5888             if ((TYPE_DUMMY_P (gnu_target_desig_type)
5889                  || get_alias_set (gnu_target_desig_type) != 0)
5890                 && (!POINTER_TYPE_P (gnu_source_type)
5891                     || (TYPE_DUMMY_P (gnu_source_desig_type)
5892                         != TYPE_DUMMY_P (gnu_target_desig_type))
5893                     || (TYPE_DUMMY_P (gnu_source_desig_type)
5894                         && gnu_source_desig_type != gnu_target_desig_type)
5895                     || !alias_sets_conflict_p
5896                         (get_alias_set (gnu_source_desig_type),
5897                          get_alias_set (gnu_target_desig_type))))
5898               {
5899                 post_error_ne
5900                   ("?possible aliasing problem for type&",
5901                    gnat_node, Target_Type (gnat_node));
5902                 post_error
5903                   ("\\?use -fno-strict-aliasing switch for references",
5904                    gnat_node);
5905                 post_error_ne
5906                   ("\\?or use `pragma No_Strict_Aliasing (&);`",
5907                    gnat_node, Target_Type (gnat_node));
5908               }
5909           }
5910
5911         /* But if the result is a fat pointer type, we have no mechanism to
5912            do that, so we unconditionally warn in problematic cases.  */
5913         else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
5914           {
5915             tree gnu_source_array_type
5916               = TYPE_IS_FAT_POINTER_P (gnu_source_type)
5917                 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
5918                 : NULL_TREE;
5919             tree gnu_target_array_type
5920               = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
5921
5922             if ((TYPE_DUMMY_P (gnu_target_array_type)
5923                  || get_alias_set (gnu_target_array_type) != 0)
5924                 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
5925                     || (TYPE_DUMMY_P (gnu_source_array_type)
5926                         != TYPE_DUMMY_P (gnu_target_array_type))
5927                     || (TYPE_DUMMY_P (gnu_source_array_type)
5928                         && gnu_source_array_type != gnu_target_array_type)
5929                     || !alias_sets_conflict_p
5930                         (get_alias_set (gnu_source_array_type),
5931                          get_alias_set (gnu_target_array_type))))
5932               {
5933                 post_error_ne
5934                   ("?possible aliasing problem for type&",
5935                    gnat_node, Target_Type (gnat_node));
5936                 post_error
5937                   ("\\?use -fno-strict-aliasing switch for references",
5938                    gnat_node);
5939               }
5940           }
5941       }
5942       gnu_result = alloc_stmt_list ();
5943       break;
5944
5945     default:
5946       /* SCIL nodes require no processing for GCC.  Other nodes should only
5947          be present when annotating types.  */
5948       gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only);
5949       gnu_result = alloc_stmt_list ();
5950     }
5951
5952   /* If we pushed the processing of the elaboration routine, pop it back.  */
5953   if (went_into_elab_proc)
5954     current_function_decl = NULL_TREE;
5955
5956   /* When not optimizing, turn boolean rvalues B into B != false tests
5957      so that the code just below can put the location information of the
5958      reference to B on the inequality operator for better debug info.  */
5959   if (!optimize
5960       && TREE_CODE (gnu_result) != INTEGER_CST
5961       && (kind == N_Identifier
5962           || kind == N_Expanded_Name
5963           || kind == N_Explicit_Dereference
5964           || kind == N_Function_Call
5965           || kind == N_Indexed_Component
5966           || kind == N_Selected_Component)
5967       && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
5968       && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
5969     gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
5970                                   convert (gnu_result_type, gnu_result),
5971                                   convert (gnu_result_type,
5972                                            boolean_false_node));
5973
5974   /* Set the location information on the result.  Note that we may have
5975      no result if we tried to build a CALL_EXPR node to a procedure with
5976      no side-effects and optimization is enabled.  */
5977   if (gnu_result && EXPR_P (gnu_result))
5978     set_gnu_expr_location_from_node (gnu_result, gnat_node);
5979
5980   /* If we're supposed to return something of void_type, it means we have
5981      something we're elaborating for effect, so just return.  */
5982   if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5983     return gnu_result;
5984
5985   /* If the result is a constant that overflowed, raise Constraint_Error.  */
5986   if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
5987     {
5988       post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
5989       gnu_result
5990         = build1 (NULL_EXPR, gnu_result_type,
5991                   build_call_raise (CE_Overflow_Check_Failed, gnat_node,
5992                                     N_Raise_Constraint_Error));
5993     }
5994
5995   /* If our result has side-effects and is of an unconstrained type,
5996      make a SAVE_EXPR so that we can be sure it will only be referenced
5997      once.  Note we must do this before any conversions.  */
5998   if (TREE_SIDE_EFFECTS (gnu_result)
5999       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
6000           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
6001     gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
6002
6003   /* Now convert the result to the result type, unless we are in one of the
6004      following cases:
6005
6006        1. If this is the Name of an assignment statement or a parameter of
6007           a procedure call, return the result almost unmodified since the
6008           RHS will have to be converted to our type in that case, unless
6009           the result type has a simpler size.  Likewise if there is just
6010           a no-op unchecked conversion in-between.  Similarly, don't convert
6011           integral types that are the operands of an unchecked conversion
6012           since we need to ignore those conversions (for 'Valid).
6013
6014        2. If we have a label (which doesn't have any well-defined type), a
6015           field or an error, return the result almost unmodified.  Similarly,
6016           if the two types are record types with the same name, don't convert.
6017           This will be the case when we are converting from a packable version
6018           of a type to its original type and we need those conversions to be
6019           NOPs in order for assignments into these types to work properly.
6020
6021        3. If the type is void or if we have no result, return error_mark_node
6022           to show we have no result.
6023
6024        4. Finally, if the type of the result is already correct.  */
6025
6026   if (Present (Parent (gnat_node))
6027       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
6028            && Name (Parent (gnat_node)) == gnat_node)
6029           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
6030               && unchecked_conversion_nop (Parent (gnat_node)))
6031           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
6032               && Name (Parent (gnat_node)) != gnat_node)
6033           || Nkind (Parent (gnat_node)) == N_Parameter_Association
6034           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
6035               && !AGGREGATE_TYPE_P (gnu_result_type)
6036               && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
6037       && !(TYPE_SIZE (gnu_result_type)
6038            && TYPE_SIZE (TREE_TYPE (gnu_result))
6039            && (AGGREGATE_TYPE_P (gnu_result_type)
6040                == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
6041            && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
6042                 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
6043                     != INTEGER_CST))
6044                || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
6045                    && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
6046                    && (CONTAINS_PLACEHOLDER_P
6047                        (TYPE_SIZE (TREE_TYPE (gnu_result))))))
6048            && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
6049                 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
6050     {
6051       /* Remove padding only if the inner object is of self-referential
6052          size: in that case it must be an object of unconstrained type
6053          with a default discriminant and we want to avoid copying too
6054          much data.  */
6055       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
6056           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
6057                                      (TREE_TYPE (gnu_result))))))
6058         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
6059                               gnu_result);
6060     }
6061
6062   else if (TREE_CODE (gnu_result) == LABEL_DECL
6063            || TREE_CODE (gnu_result) == FIELD_DECL
6064            || TREE_CODE (gnu_result) == ERROR_MARK
6065            || (TYPE_NAME (gnu_result_type)
6066                == TYPE_NAME (TREE_TYPE (gnu_result))
6067                && TREE_CODE (gnu_result_type) == RECORD_TYPE
6068                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
6069     {
6070       /* Remove any padding.  */
6071       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
6072         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
6073                               gnu_result);
6074     }
6075
6076   else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
6077     gnu_result = error_mark_node;
6078
6079   else if (gnu_result_type != TREE_TYPE (gnu_result))
6080     gnu_result = convert (gnu_result_type, gnu_result);
6081
6082   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result.  */
6083   while ((TREE_CODE (gnu_result) == NOP_EXPR
6084           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
6085          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
6086     gnu_result = TREE_OPERAND (gnu_result, 0);
6087
6088   return gnu_result;
6089 }
6090 \f
6091 /* Subroutine of above to push the exception label stack.  GNU_STACK is
6092    a pointer to the stack to update and GNAT_LABEL, if present, is the
6093    label to push onto the stack.  */
6094
6095 static void
6096 push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label)
6097 {
6098   tree gnu_label = (Present (gnat_label)
6099                     ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
6100                     : NULL_TREE);
6101
6102   VEC_safe_push (tree, gc, *gnu_stack, gnu_label);
6103 }
6104 \f
6105 /* Record the current code position in GNAT_NODE.  */
6106
6107 static void
6108 record_code_position (Node_Id gnat_node)
6109 {
6110   tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
6111
6112   add_stmt_with_node (stmt_stmt, gnat_node);
6113   save_gnu_tree (gnat_node, stmt_stmt, true);
6114 }
6115
6116 /* Insert the code for GNAT_NODE at the position saved for that node.  */
6117
6118 static void
6119 insert_code_for (Node_Id gnat_node)
6120 {
6121   STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
6122   save_gnu_tree (gnat_node, NULL_TREE, true);
6123 }
6124 \f
6125 /* Start a new statement group chained to the previous group.  */
6126
6127 void
6128 start_stmt_group (void)
6129 {
6130   struct stmt_group *group = stmt_group_free_list;
6131
6132   /* First see if we can get one from the free list.  */
6133   if (group)
6134     stmt_group_free_list = group->previous;
6135   else
6136     group = ggc_alloc_stmt_group ();
6137
6138   group->previous = current_stmt_group;
6139   group->stmt_list = group->block = group->cleanups = NULL_TREE;
6140   current_stmt_group = group;
6141 }
6142
6143 /* Add GNU_STMT to the current statement group.  If it is an expression with
6144    no effects, it is ignored.  */
6145
6146 void
6147 add_stmt (tree gnu_stmt)
6148 {
6149   append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
6150 }
6151
6152 /* Similar, but the statement is always added, regardless of side-effects.  */
6153
6154 void
6155 add_stmt_force (tree gnu_stmt)
6156 {
6157   append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
6158 }
6159
6160 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE.  */
6161
6162 void
6163 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
6164 {
6165   if (Present (gnat_node))
6166     set_expr_location_from_node (gnu_stmt, gnat_node);
6167   add_stmt (gnu_stmt);
6168 }
6169
6170 /* Similar, but the statement is always added, regardless of side-effects.  */
6171
6172 void
6173 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
6174 {
6175   if (Present (gnat_node))
6176     set_expr_location_from_node (gnu_stmt, gnat_node);
6177   add_stmt_force (gnu_stmt);
6178 }
6179
6180 /* Add a declaration statement for GNU_DECL to the current statement group.
6181    Get SLOC from Entity_Id.  */
6182
6183 void
6184 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
6185 {
6186   tree type = TREE_TYPE (gnu_decl);
6187   tree gnu_stmt, gnu_init, t;
6188
6189   /* If this is a variable that Gigi is to ignore, we may have been given
6190      an ERROR_MARK.  So test for it.  We also might have been given a
6191      reference for a renaming.  So only do something for a decl.  Also
6192      ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE.  */
6193   if (!DECL_P (gnu_decl)
6194       || (TREE_CODE (gnu_decl) == TYPE_DECL
6195           && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
6196     return;
6197
6198   gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
6199
6200   /* If we are global, we don't want to actually output the DECL_EXPR for
6201      this decl since we already have evaluated the expressions in the
6202      sizes and positions as globals and doing it again would be wrong.  */
6203   if (global_bindings_p ())
6204     {
6205       /* Mark everything as used to prevent node sharing with subprograms.
6206          Note that walk_tree knows how to deal with TYPE_DECL, but neither
6207          VAR_DECL nor CONST_DECL.  This appears to be somewhat arbitrary.  */
6208       MARK_VISITED (gnu_stmt);
6209       if (TREE_CODE (gnu_decl) == VAR_DECL
6210           || TREE_CODE (gnu_decl) == CONST_DECL)
6211         {
6212           MARK_VISITED (DECL_SIZE (gnu_decl));
6213           MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
6214           MARK_VISITED (DECL_INITIAL (gnu_decl));
6215         }
6216       /* In any case, we have to deal with our own TYPE_ADA_SIZE field.  */
6217       else if (TREE_CODE (gnu_decl) == TYPE_DECL
6218                && ((TREE_CODE (type) == RECORD_TYPE
6219                     && !TYPE_FAT_POINTER_P (type))
6220                    || TREE_CODE (type) == UNION_TYPE
6221                    || TREE_CODE (type) == QUAL_UNION_TYPE))
6222         MARK_VISITED (TYPE_ADA_SIZE (type));
6223     }
6224   else if (!DECL_EXTERNAL (gnu_decl))
6225     add_stmt_with_node (gnu_stmt, gnat_entity);
6226
6227   /* If this is a variable and an initializer is attached to it, it must be
6228      valid for the context.  Similar to init_const in create_var_decl_1.  */
6229   if (TREE_CODE (gnu_decl) == VAR_DECL
6230       && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
6231       && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
6232           || (TREE_STATIC (gnu_decl)
6233               && !initializer_constant_valid_p (gnu_init,
6234                                                 TREE_TYPE (gnu_init)))))
6235     {
6236       /* If GNU_DECL has a padded type, convert it to the unpadded
6237          type so the assignment is done properly.  */
6238       if (TYPE_IS_PADDING_P (type))
6239         t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
6240       else
6241         t = gnu_decl;
6242
6243       gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
6244
6245       DECL_INITIAL (gnu_decl) = NULL_TREE;
6246       if (TREE_READONLY (gnu_decl))
6247         {
6248           TREE_READONLY (gnu_decl) = 0;
6249           DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
6250         }
6251
6252       add_stmt_with_node (gnu_stmt, gnat_entity);
6253     }
6254 }
6255
6256 /* Callback for walk_tree to mark the visited trees rooted at *TP.  */
6257
6258 static tree
6259 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
6260 {
6261   tree t = *tp;
6262
6263   if (TREE_VISITED (t))
6264     *walk_subtrees = 0;
6265
6266   /* Don't mark a dummy type as visited because we want to mark its sizes
6267      and fields once it's filled in.  */
6268   else if (!TYPE_IS_DUMMY_P (t))
6269     TREE_VISITED (t) = 1;
6270
6271   if (TYPE_P (t))
6272     TYPE_SIZES_GIMPLIFIED (t) = 1;
6273
6274   return NULL_TREE;
6275 }
6276
6277 /* Mark nodes rooted at T with TREE_VISITED and types as having their
6278    sized gimplified.  We use this to indicate all variable sizes and
6279    positions in global types may not be shared by any subprogram.  */
6280
6281 void
6282 mark_visited (tree t)
6283 {
6284   walk_tree (&t, mark_visited_r, NULL, NULL);
6285 }
6286
6287 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
6288    set its location to that of GNAT_NODE if present.  */
6289
6290 static void
6291 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
6292 {
6293   if (Present (gnat_node))
6294     set_expr_location_from_node (gnu_cleanup, gnat_node);
6295   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
6296 }
6297
6298 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
6299
6300 void
6301 set_block_for_group (tree gnu_block)
6302 {
6303   gcc_assert (!current_stmt_group->block);
6304   current_stmt_group->block = gnu_block;
6305 }
6306
6307 /* Return code corresponding to the current code group.  It is normally
6308    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
6309    BLOCK or cleanups were set.  */
6310
6311 tree
6312 end_stmt_group (void)
6313 {
6314   struct stmt_group *group = current_stmt_group;
6315   tree gnu_retval = group->stmt_list;
6316
6317   /* If this is a null list, allocate a new STATEMENT_LIST.  Then, if there
6318      are cleanups, make a TRY_FINALLY_EXPR.  Last, if there is a BLOCK,
6319      make a BIND_EXPR.  Note that we nest in that because the cleanup may
6320      reference variables in the block.  */
6321   if (gnu_retval == NULL_TREE)
6322     gnu_retval = alloc_stmt_list ();
6323
6324   if (group->cleanups)
6325     gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
6326                          group->cleanups);
6327
6328   if (current_stmt_group->block)
6329     gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
6330                          gnu_retval, group->block);
6331
6332   /* Remove this group from the stack and add it to the free list.  */
6333   current_stmt_group = group->previous;
6334   group->previous = stmt_group_free_list;
6335   stmt_group_free_list = group;
6336
6337   return gnu_retval;
6338 }
6339
6340 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
6341    statements.*/
6342
6343 static void
6344 add_stmt_list (List_Id gnat_list)
6345 {
6346   Node_Id gnat_node;
6347
6348   if (Present (gnat_list))
6349     for (gnat_node = First (gnat_list); Present (gnat_node);
6350          gnat_node = Next (gnat_node))
6351       add_stmt (gnat_to_gnu (gnat_node));
6352 }
6353
6354 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
6355    If BINDING_P is true, push and pop a binding level around the list.  */
6356
6357 static tree
6358 build_stmt_group (List_Id gnat_list, bool binding_p)
6359 {
6360   start_stmt_group ();
6361   if (binding_p)
6362     gnat_pushlevel ();
6363
6364   add_stmt_list (gnat_list);
6365   if (binding_p)
6366     gnat_poplevel ();
6367
6368   return end_stmt_group ();
6369 }
6370 \f
6371 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
6372
6373 int
6374 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
6375                     gimple_seq *post_p ATTRIBUTE_UNUSED)
6376 {
6377   tree expr = *expr_p;
6378   tree op;
6379
6380   if (IS_ADA_STMT (expr))
6381     return gnat_gimplify_stmt (expr_p);
6382
6383   switch (TREE_CODE (expr))
6384     {
6385     case NULL_EXPR:
6386       /* If this is for a scalar, just make a VAR_DECL for it.  If for
6387          an aggregate, get a null pointer of the appropriate type and
6388          dereference it.  */
6389       if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
6390         *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
6391                           convert (build_pointer_type (TREE_TYPE (expr)),
6392                                    integer_zero_node));
6393       else
6394         {
6395           *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
6396           TREE_NO_WARNING (*expr_p) = 1;
6397         }
6398
6399       gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
6400       return GS_OK;
6401
6402     case UNCONSTRAINED_ARRAY_REF:
6403       /* We should only do this if we are just elaborating for side-effects,
6404          but we can't know that yet.  */
6405       *expr_p = TREE_OPERAND (*expr_p, 0);
6406       return GS_OK;
6407
6408     case ADDR_EXPR:
6409       op = TREE_OPERAND (expr, 0);
6410
6411       /* If we are taking the address of a constant CONSTRUCTOR, make sure it
6412          is put into static memory.  We know that it's going to be read-only
6413          given the semantics we have and it must be in static memory when the
6414          reference is in an elaboration procedure.  */
6415       if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
6416         {
6417           tree addr = build_fold_addr_expr (tree_output_constant_def (op));
6418           *expr_p = fold_convert (TREE_TYPE (expr), addr);
6419           return GS_ALL_DONE;
6420         }
6421
6422       /* Otherwise, if we are taking the address of a non-constant CONSTRUCTOR
6423          or of a call, explicitly create the local temporary.  That's required
6424          if the type is passed by reference.  */
6425       if (TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
6426         {
6427           tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
6428           TREE_ADDRESSABLE (new_var) = 1;
6429           gimple_add_tmp_var (new_var);
6430
6431           mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
6432           gimplify_and_add (mod, pre_p);
6433
6434           TREE_OPERAND (expr, 0) = new_var;
6435           recompute_tree_invariant_for_addr_expr (expr);
6436           return GS_ALL_DONE;
6437         }
6438
6439       return GS_UNHANDLED;
6440
6441     case VIEW_CONVERT_EXPR:
6442       op = TREE_OPERAND (expr, 0);
6443
6444       /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
6445          type to a scalar one, explicitly create the local temporary.  That's
6446          required if the type is passed by reference.  */
6447       if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
6448           && AGGREGATE_TYPE_P (TREE_TYPE (op))
6449           && !AGGREGATE_TYPE_P (TREE_TYPE (expr)))
6450         {
6451           tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
6452           gimple_add_tmp_var (new_var);
6453
6454           mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
6455           gimplify_and_add (mod, pre_p);
6456
6457           TREE_OPERAND (expr, 0) = new_var;
6458           return GS_OK;
6459         }
6460
6461       return GS_UNHANDLED;
6462
6463     case DECL_EXPR:
6464       op = DECL_EXPR_DECL (expr);
6465
6466       /* The expressions for the RM bounds must be gimplified to ensure that
6467          they are properly elaborated.  See gimplify_decl_expr.  */
6468       if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
6469           && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
6470         switch (TREE_CODE (TREE_TYPE (op)))
6471           {
6472           case INTEGER_TYPE:
6473           case ENUMERAL_TYPE:
6474           case BOOLEAN_TYPE:
6475           case REAL_TYPE:
6476             {
6477               tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
6478
6479               val = TYPE_RM_MIN_VALUE (type);
6480               if (val)
6481                 {
6482                   gimplify_one_sizepos (&val, pre_p);
6483                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
6484                     SET_TYPE_RM_MIN_VALUE (t, val);
6485                 }
6486
6487               val = TYPE_RM_MAX_VALUE (type);
6488               if (val)
6489                 {
6490                   gimplify_one_sizepos (&val, pre_p);
6491                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
6492                     SET_TYPE_RM_MAX_VALUE (t, val);
6493                 }
6494
6495             }
6496             break;
6497
6498           default:
6499             break;
6500           }
6501
6502       /* ... fall through ... */
6503
6504     default:
6505       return GS_UNHANDLED;
6506     }
6507 }
6508
6509 /* Generate GIMPLE in place for the statement at *STMT_P.  */
6510
6511 static enum gimplify_status
6512 gnat_gimplify_stmt (tree *stmt_p)
6513 {
6514   tree stmt = *stmt_p;
6515
6516   switch (TREE_CODE (stmt))
6517     {
6518     case STMT_STMT:
6519       *stmt_p = STMT_STMT_STMT (stmt);
6520       return GS_OK;
6521
6522     case LOOP_STMT:
6523       {
6524         tree gnu_start_label = create_artificial_label (input_location);
6525         tree gnu_cond = LOOP_STMT_COND (stmt);
6526         tree gnu_update = LOOP_STMT_UPDATE (stmt);
6527         tree gnu_end_label = LOOP_STMT_LABEL (stmt);
6528         tree t;
6529
6530         /* Build the condition expression from the test, if any.  */
6531         if (gnu_cond)
6532           gnu_cond
6533             = build3 (COND_EXPR, void_type_node, gnu_cond, alloc_stmt_list (),
6534                       build1 (GOTO_EXPR, void_type_node, gnu_end_label));
6535
6536         /* Set to emit the statements of the loop.  */
6537         *stmt_p = NULL_TREE;
6538
6539         /* We first emit the start label and then a conditional jump to the
6540            end label if there's a top condition, then the update if it's at
6541            the top, then the body of the loop, then a conditional jump to
6542            the end label if there's a bottom condition, then the update if
6543            it's at the bottom, and finally a jump to the start label and the
6544            definition of the end label.  */
6545         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
6546                                           gnu_start_label),
6547                                   stmt_p);
6548
6549         if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
6550           append_to_statement_list (gnu_cond, stmt_p);
6551
6552         if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
6553           append_to_statement_list (gnu_update, stmt_p);
6554
6555         append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
6556
6557         if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
6558           append_to_statement_list (gnu_cond, stmt_p);
6559
6560         if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
6561           append_to_statement_list (gnu_update, stmt_p);
6562
6563         t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
6564         SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
6565         append_to_statement_list (t, stmt_p);
6566
6567         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
6568                                           gnu_end_label),
6569                                   stmt_p);
6570         return GS_OK;
6571       }
6572
6573     case EXIT_STMT:
6574       /* Build a statement to jump to the corresponding end label, then
6575          see if it needs to be conditional.  */
6576       *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
6577       if (EXIT_STMT_COND (stmt))
6578         *stmt_p = build3 (COND_EXPR, void_type_node,
6579                           EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
6580       return GS_OK;
6581
6582     default:
6583       gcc_unreachable ();
6584     }
6585 }
6586 \f
6587 /* Force references to each of the entities in packages withed by GNAT_NODE.
6588    Operate recursively but check that we aren't elaborating something more
6589    than once.
6590
6591    This routine is exclusively called in type_annotate mode, to compute DDA
6592    information for types in withed units, for ASIS use.  */
6593
6594 static void
6595 elaborate_all_entities (Node_Id gnat_node)
6596 {
6597   Entity_Id gnat_with_clause, gnat_entity;
6598
6599   /* Process each unit only once.  As we trace the context of all relevant
6600      units transitively, including generic bodies, we may encounter the
6601      same generic unit repeatedly.  */
6602   if (!present_gnu_tree (gnat_node))
6603      save_gnu_tree (gnat_node, integer_zero_node, true);
6604
6605   /* Save entities in all context units.  A body may have an implicit_with
6606      on its own spec, if the context includes a child unit, so don't save
6607      the spec twice.  */
6608   for (gnat_with_clause = First (Context_Items (gnat_node));
6609        Present (gnat_with_clause);
6610        gnat_with_clause = Next (gnat_with_clause))
6611     if (Nkind (gnat_with_clause) == N_With_Clause
6612         && !present_gnu_tree (Library_Unit (gnat_with_clause))
6613         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
6614       {
6615         elaborate_all_entities (Library_Unit (gnat_with_clause));
6616
6617         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
6618           {
6619             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
6620                  Present (gnat_entity);
6621                  gnat_entity = Next_Entity (gnat_entity))
6622               if (Is_Public (gnat_entity)
6623                   && Convention (gnat_entity) != Convention_Intrinsic
6624                   && Ekind (gnat_entity) != E_Package
6625                   && Ekind (gnat_entity) != E_Package_Body
6626                   && Ekind (gnat_entity) != E_Operator
6627                   && !(IN (Ekind (gnat_entity), Type_Kind)
6628                        && !Is_Frozen (gnat_entity))
6629                   && !((Ekind (gnat_entity) == E_Procedure
6630                         || Ekind (gnat_entity) == E_Function)
6631                        && Is_Intrinsic_Subprogram (gnat_entity))
6632                   && !IN (Ekind (gnat_entity), Named_Kind)
6633                   && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
6634                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
6635           }
6636         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
6637           {
6638             Node_Id gnat_body
6639               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
6640
6641             /* Retrieve compilation unit node of generic body.  */
6642             while (Present (gnat_body)
6643                    && Nkind (gnat_body) != N_Compilation_Unit)
6644               gnat_body = Parent (gnat_body);
6645
6646             /* If body is available, elaborate its context.  */
6647             if (Present (gnat_body))
6648               elaborate_all_entities (gnat_body);
6649           }
6650       }
6651
6652   if (Nkind (Unit (gnat_node)) == N_Package_Body)
6653     elaborate_all_entities (Library_Unit (gnat_node));
6654 }
6655 \f
6656 /* Do the processing of GNAT_NODE, an N_Freeze_Entity.  */
6657
6658 static void
6659 process_freeze_entity (Node_Id gnat_node)
6660 {
6661   const Entity_Id gnat_entity = Entity (gnat_node);
6662   const Entity_Kind kind = Ekind (gnat_entity);
6663   tree gnu_old, gnu_new;
6664
6665   /* If this is a package, we need to generate code for the package.  */
6666   if (kind == E_Package)
6667     {
6668       insert_code_for
6669         (Parent (Corresponding_Body
6670                  (Parent (Declaration_Node (gnat_entity)))));
6671       return;
6672     }
6673
6674   /* Don't do anything for class-wide types as they are always transformed
6675      into their root type.  */
6676   if (kind == E_Class_Wide_Type)
6677     return;
6678
6679   /* Check for an old definition.  This freeze node might be for an Itype.  */
6680   gnu_old
6681     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
6682
6683   /* If this entity has an address representation clause, GNU_OLD is the
6684      address, so discard it here.  */
6685   if (Present (Address_Clause (gnat_entity)))
6686     gnu_old = NULL_TREE;
6687
6688   /* Don't do anything for subprograms that may have been elaborated before
6689      their freeze nodes.  This can happen, for example, because of an inner
6690      call in an instance body or because of previous compilation of a spec
6691      for inlining purposes.  */
6692   if (gnu_old
6693       && ((TREE_CODE (gnu_old) == FUNCTION_DECL
6694            && (kind == E_Function || kind == E_Procedure))
6695           || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
6696               && kind == E_Subprogram_Type)))
6697     return;
6698
6699   /* If we have a non-dummy type old tree, we have nothing to do, except
6700      aborting if this is the public view of a private type whose full view was
6701      not delayed, as this node was never delayed as it should have been.  We
6702      let this happen for concurrent types and their Corresponding_Record_Type,
6703      however, because each might legitimately be elaborated before its own
6704      freeze node, e.g. while processing the other.  */
6705   if (gnu_old
6706       && !(TREE_CODE (gnu_old) == TYPE_DECL
6707            && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
6708     {
6709       gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
6710                    && Present (Full_View (gnat_entity))
6711                    && No (Freeze_Node (Full_View (gnat_entity))))
6712                   || Is_Concurrent_Type (gnat_entity)
6713                   || (IN (kind, Record_Kind)
6714                       && Is_Concurrent_Record_Type (gnat_entity)));
6715       return;
6716     }
6717
6718   /* Reset the saved tree, if any, and elaborate the object or type for real.
6719      If there is a full view, elaborate it and use the result.  And, if this
6720      is the root type of a class-wide type, reuse it for the latter.  */
6721   if (gnu_old)
6722     {
6723       save_gnu_tree (gnat_entity, NULL_TREE, false);
6724       if (IN (kind, Incomplete_Or_Private_Kind)
6725           && Present (Full_View (gnat_entity))
6726           && present_gnu_tree (Full_View (gnat_entity)))
6727         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
6728       if (IN (kind, Type_Kind)
6729           && Present (Class_Wide_Type (gnat_entity))
6730           && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6731         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
6732     }
6733
6734   if (IN (kind, Incomplete_Or_Private_Kind)
6735       && Present (Full_View (gnat_entity)))
6736     {
6737       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
6738
6739       /* Propagate back-annotations from full view to partial view.  */
6740       if (Unknown_Alignment (gnat_entity))
6741         Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
6742
6743       if (Unknown_Esize (gnat_entity))
6744         Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
6745
6746       if (Unknown_RM_Size (gnat_entity))
6747         Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
6748
6749       /* The above call may have defined this entity (the simplest example
6750          of this is when we have a private enumeral type since the bounds
6751          will have the public view).  */
6752       if (!present_gnu_tree (gnat_entity))
6753         save_gnu_tree (gnat_entity, gnu_new, false);
6754     }
6755   else
6756     {
6757       tree gnu_init
6758         = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
6759            && present_gnu_tree (Declaration_Node (gnat_entity)))
6760           ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
6761
6762       gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
6763     }
6764
6765   if (IN (kind, Type_Kind)
6766       && Present (Class_Wide_Type (gnat_entity))
6767       && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6768     save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
6769
6770   /* If we have an old type and we've made pointers to this type, update those
6771      pointers.  If this is a Taft amendment type in the main unit, we need to
6772      mark the type as used since other units referencing it don't see the full
6773      declaration and, therefore, cannot mark it as used themselves.  */
6774   if (gnu_old)
6775     {
6776       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
6777                          TREE_TYPE (gnu_new));
6778       if (DECL_TAFT_TYPE_P (gnu_old))
6779         used_types_insert (TREE_TYPE (gnu_new));
6780     }
6781 }
6782 \f
6783 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
6784    We make two passes, one to elaborate anything other than bodies (but
6785    we declare a function if there was no spec).  The second pass
6786    elaborates the bodies.
6787
6788    GNAT_END_LIST gives the element in the list past the end.  Normally,
6789    this is Empty, but can be First_Real_Statement for a
6790    Handled_Sequence_Of_Statements.
6791
6792    We make a complete pass through both lists if PASS1P is true, then make
6793    the second pass over both lists if PASS2P is true.  The lists usually
6794    correspond to the public and private parts of a package.  */
6795
6796 static void
6797 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
6798                Node_Id gnat_end_list, bool pass1p, bool pass2p)
6799 {
6800   List_Id gnat_decl_array[2];
6801   Node_Id gnat_decl;
6802   int i;
6803
6804   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
6805
6806   if (pass1p)
6807     for (i = 0; i <= 1; i++)
6808       if (Present (gnat_decl_array[i]))
6809         for (gnat_decl = First (gnat_decl_array[i]);
6810              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6811           {
6812             /* For package specs, we recurse inside the declarations,
6813                thus taking the two pass approach inside the boundary.  */
6814             if (Nkind (gnat_decl) == N_Package_Declaration
6815                 && (Nkind (Specification (gnat_decl)
6816                            == N_Package_Specification)))
6817               process_decls (Visible_Declarations (Specification (gnat_decl)),
6818                              Private_Declarations (Specification (gnat_decl)),
6819                              Empty, true, false);
6820
6821             /* Similarly for any declarations in the actions of a
6822                freeze node.  */
6823             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6824               {
6825                 process_freeze_entity (gnat_decl);
6826                 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
6827               }
6828
6829             /* Package bodies with freeze nodes get their elaboration deferred
6830                until the freeze node, but the code must be placed in the right
6831                place, so record the code position now.  */
6832             else if (Nkind (gnat_decl) == N_Package_Body
6833                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
6834               record_code_position (gnat_decl);
6835
6836             else if (Nkind (gnat_decl) == N_Package_Body_Stub
6837                      && Present (Library_Unit (gnat_decl))
6838                      && Present (Freeze_Node
6839                                  (Corresponding_Spec
6840                                   (Proper_Body (Unit
6841                                                 (Library_Unit (gnat_decl)))))))
6842               record_code_position
6843                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
6844
6845             /* We defer most subprogram bodies to the second pass.  */
6846             else if (Nkind (gnat_decl) == N_Subprogram_Body)
6847               {
6848                 if (Acts_As_Spec (gnat_decl))
6849                   {
6850                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
6851
6852                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
6853                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6854                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6855                   }
6856               }
6857
6858             /* For bodies and stubs that act as their own specs, the entity
6859                itself must be elaborated in the first pass, because it may
6860                be used in other declarations.  */
6861             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
6862               {
6863                 Node_Id gnat_subprog_id
6864                   = Defining_Entity (Specification (gnat_decl));
6865
6866                     if (Ekind (gnat_subprog_id) != E_Subprogram_Body
6867                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
6868                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6869                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6870               }
6871
6872             /* Concurrent stubs stand for the corresponding subprogram bodies,
6873                which are deferred like other bodies.  */
6874             else if (Nkind (gnat_decl) == N_Task_Body_Stub
6875                      || Nkind (gnat_decl) == N_Protected_Body_Stub)
6876               ;
6877
6878             else
6879               add_stmt (gnat_to_gnu (gnat_decl));
6880           }
6881
6882   /* Here we elaborate everything we deferred above except for package bodies,
6883      which are elaborated at their freeze nodes.  Note that we must also
6884      go inside things (package specs and freeze nodes) the first pass did.  */
6885   if (pass2p)
6886     for (i = 0; i <= 1; i++)
6887       if (Present (gnat_decl_array[i]))
6888         for (gnat_decl = First (gnat_decl_array[i]);
6889              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6890           {
6891             if (Nkind (gnat_decl) == N_Subprogram_Body
6892                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
6893                 || Nkind (gnat_decl) == N_Task_Body_Stub
6894                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
6895               add_stmt (gnat_to_gnu (gnat_decl));
6896
6897             else if (Nkind (gnat_decl) == N_Package_Declaration
6898                      && (Nkind (Specification (gnat_decl)
6899                                 == N_Package_Specification)))
6900               process_decls (Visible_Declarations (Specification (gnat_decl)),
6901                              Private_Declarations (Specification (gnat_decl)),
6902                              Empty, false, true);
6903
6904             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6905               process_decls (Actions (gnat_decl), Empty, Empty, false, true);
6906           }
6907 }
6908 \f
6909 /* Make a unary operation of kind CODE using build_unary_op, but guard
6910    the operation by an overflow check.  CODE can be one of NEGATE_EXPR
6911    or ABS_EXPR.  GNU_TYPE is the type desired for the result.  Usually
6912    the operation is to be performed in that type.  GNAT_NODE is the gnat
6913    node conveying the source location for which the error should be
6914    signaled.  */
6915
6916 static tree
6917 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
6918                       Node_Id gnat_node)
6919 {
6920   gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
6921
6922   operand = gnat_protect_expr (operand);
6923
6924   return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
6925                                       operand, TYPE_MIN_VALUE (gnu_type)),
6926                      build_unary_op (code, gnu_type, operand),
6927                      CE_Overflow_Check_Failed, gnat_node);
6928 }
6929
6930 /* Make a binary operation of kind CODE using build_binary_op, but guard
6931    the operation by an overflow check.  CODE can be one of PLUS_EXPR,
6932    MINUS_EXPR or MULT_EXPR.  GNU_TYPE is the type desired for the result.
6933    Usually the operation is to be performed in that type.  GNAT_NODE is
6934    the GNAT node conveying the source location for which the error should
6935    be signaled.  */
6936
6937 static tree
6938 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
6939                        tree right, Node_Id gnat_node)
6940 {
6941   tree lhs = gnat_protect_expr (left);
6942   tree rhs = gnat_protect_expr (right);
6943   tree type_max = TYPE_MAX_VALUE (gnu_type);
6944   tree type_min = TYPE_MIN_VALUE (gnu_type);
6945   tree gnu_expr;
6946   tree tmp1, tmp2;
6947   tree zero = convert (gnu_type, integer_zero_node);
6948   tree rhs_lt_zero;
6949   tree check_pos;
6950   tree check_neg;
6951   tree check;
6952   int precision = TYPE_PRECISION (gnu_type);
6953
6954   gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */
6955
6956   /* Prefer a constant or known-positive rhs to simplify checks.  */
6957   if (!TREE_CONSTANT (rhs)
6958       && commutative_tree_code (code)
6959       && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs)
6960                                   && tree_expr_nonnegative_p (lhs))))
6961     {
6962       tree tmp = lhs;
6963       lhs = rhs;
6964       rhs = tmp;
6965     }
6966
6967   rhs_lt_zero = tree_expr_nonnegative_p (rhs)
6968                 ? boolean_false_node
6969                 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
6970
6971   /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
6972
6973   /* Try a few strategies that may be cheaper than the general
6974      code at the end of the function, if the rhs is not known.
6975      The strategies are:
6976        - Call library function for 64-bit multiplication (complex)
6977        - Widen, if input arguments are sufficiently small
6978        - Determine overflow using wrapped result for addition/subtraction.  */
6979
6980   if (!TREE_CONSTANT (rhs))
6981     {
6982       /* Even for add/subtract double size to get another base type.  */
6983       int needed_precision = precision * 2;
6984
6985       if (code == MULT_EXPR && precision == 64)
6986         {
6987           tree int_64 = gnat_type_for_size (64, 0);
6988
6989           return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
6990                                                        convert (int_64, lhs),
6991                                                        convert (int_64, rhs)));
6992         }
6993
6994       else if (needed_precision <= BITS_PER_WORD
6995                || (code == MULT_EXPR
6996                    && needed_precision <= LONG_LONG_TYPE_SIZE))
6997         {
6998           tree wide_type = gnat_type_for_size (needed_precision, 0);
6999
7000           tree wide_result = build_binary_op (code, wide_type,
7001                                               convert (wide_type, lhs),
7002                                               convert (wide_type, rhs));
7003
7004           tree check = build_binary_op
7005             (TRUTH_ORIF_EXPR, boolean_type_node,
7006              build_binary_op (LT_EXPR, boolean_type_node, wide_result,
7007                               convert (wide_type, type_min)),
7008              build_binary_op (GT_EXPR, boolean_type_node, wide_result,
7009                               convert (wide_type, type_max)));
7010
7011           tree result = convert (gnu_type, wide_result);
7012
7013           return
7014             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
7015         }
7016
7017       else if (code == PLUS_EXPR || code == MINUS_EXPR)
7018         {
7019           tree unsigned_type = gnat_type_for_size (precision, 1);
7020           tree wrapped_expr = convert
7021             (gnu_type, build_binary_op (code, unsigned_type,
7022                                         convert (unsigned_type, lhs),
7023                                         convert (unsigned_type, rhs)));
7024
7025           tree result = convert
7026             (gnu_type, build_binary_op (code, gnu_type, lhs, rhs));
7027
7028           /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
7029              or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction.  */
7030           tree check = build_binary_op
7031             (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
7032              build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
7033                               boolean_type_node, wrapped_expr, lhs));
7034
7035           return
7036             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
7037         }
7038    }
7039
7040   switch (code)
7041     {
7042     case PLUS_EXPR:
7043       /* When rhs >= 0, overflow when lhs > type_max - rhs.  */
7044       check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
7045                                    build_binary_op (MINUS_EXPR, gnu_type,
7046                                                     type_max, rhs)),
7047
7048       /* When rhs < 0, overflow when lhs < type_min - rhs.  */
7049       check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
7050                                    build_binary_op (MINUS_EXPR, gnu_type,
7051                                                     type_min, rhs));
7052       break;
7053
7054     case MINUS_EXPR:
7055       /* When rhs >= 0, overflow when lhs < type_min + rhs.  */
7056       check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
7057                                    build_binary_op (PLUS_EXPR, gnu_type,
7058                                                     type_min, rhs)),
7059
7060       /* When rhs < 0, overflow when lhs > type_max + rhs.  */
7061       check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
7062                                    build_binary_op (PLUS_EXPR, gnu_type,
7063                                                     type_max, rhs));
7064       break;
7065
7066     case MULT_EXPR:
7067       /* The check here is designed to be efficient if the rhs is constant,
7068          but it will work for any rhs by using integer division.
7069          Four different check expressions determine whether X * C overflows,
7070          depending on C.
7071            C ==  0  =>  false
7072            C  >  0  =>  X > type_max / C || X < type_min / C
7073            C == -1  =>  X == type_min
7074            C  < -1  =>  X > type_min / C || X < type_max / C */
7075
7076       tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
7077       tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
7078
7079       check_pos
7080         = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
7081                            build_binary_op (NE_EXPR, boolean_type_node, zero,
7082                                             rhs),
7083                            build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7084                                             build_binary_op (GT_EXPR,
7085                                                              boolean_type_node,
7086                                                              lhs, tmp1),
7087                                             build_binary_op (LT_EXPR,
7088                                                              boolean_type_node,
7089                                                              lhs, tmp2)));
7090
7091       check_neg
7092         = fold_build3 (COND_EXPR, boolean_type_node,
7093                        build_binary_op (EQ_EXPR, boolean_type_node, rhs,
7094                                         build_int_cst (gnu_type, -1)),
7095                        build_binary_op (EQ_EXPR, boolean_type_node, lhs,
7096                                         type_min),
7097                        build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7098                                         build_binary_op (GT_EXPR,
7099                                                          boolean_type_node,
7100                                                          lhs, tmp2),
7101                                         build_binary_op (LT_EXPR,
7102                                                          boolean_type_node,
7103                                                          lhs, tmp1)));
7104       break;
7105
7106     default:
7107       gcc_unreachable();
7108     }
7109
7110   gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
7111
7112   /* If we can fold the expression to a constant, just return it.
7113      The caller will deal with overflow, no need to generate a check.  */
7114   if (TREE_CONSTANT (gnu_expr))
7115     return gnu_expr;
7116
7117   check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
7118                        check_pos);
7119
7120   return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
7121 }
7122
7123 /* Emit code for a range check.  GNU_EXPR is the expression to be checked,
7124    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
7125    which we have to check.  GNAT_NODE is the GNAT node conveying the source
7126    location for which the error should be signaled.  */
7127
7128 static tree
7129 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
7130 {
7131   tree gnu_range_type = get_unpadded_type (gnat_range_type);
7132   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
7133   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
7134   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
7135
7136   /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
7137      This can for example happen when translating 'Val or 'Value.  */
7138   if (gnu_compare_type == gnu_range_type)
7139     return gnu_expr;
7140
7141   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
7142      we can't do anything since we might be truncating the bounds.  No
7143      check is needed in this case.  */
7144   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
7145       && (TYPE_PRECISION (gnu_compare_type)
7146           < TYPE_PRECISION (get_base_type (gnu_range_type))))
7147     return gnu_expr;
7148
7149   /* Checked expressions must be evaluated only once.  */
7150   gnu_expr = gnat_protect_expr (gnu_expr);
7151
7152   /* Note that the form of the check is
7153         (not (expr >= lo)) or (not (expr <= hi))
7154      the reason for this slightly convoluted form is that NaNs
7155      are not considered to be in range in the float case.  */
7156   return emit_check
7157     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7158                       invert_truthvalue
7159                       (build_binary_op (GE_EXPR, boolean_type_node,
7160                                        convert (gnu_compare_type, gnu_expr),
7161                                        convert (gnu_compare_type, gnu_low))),
7162                       invert_truthvalue
7163                       (build_binary_op (LE_EXPR, boolean_type_node,
7164                                         convert (gnu_compare_type, gnu_expr),
7165                                         convert (gnu_compare_type,
7166                                                  gnu_high)))),
7167      gnu_expr, CE_Range_Check_Failed, gnat_node);
7168 }
7169 \f
7170 /* Emit code for an index check.  GNU_ARRAY_OBJECT is the array object which
7171    we are about to index, GNU_EXPR is the index expression to be checked,
7172    GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
7173    has to be checked.  Note that for index checking we cannot simply use the
7174    emit_range_check function (although very similar code needs to be generated
7175    in both cases) since for index checking the array type against which we are
7176    checking the indices may be unconstrained and consequently we need to get
7177    the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
7178    The place where we need to do that is in subprograms having unconstrained
7179    array formal parameters.  GNAT_NODE is the GNAT node conveying the source
7180    location for which the error should be signaled.  */
7181
7182 static tree
7183 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
7184                   tree gnu_high, Node_Id gnat_node)
7185 {
7186   tree gnu_expr_check;
7187
7188   /* Checked expressions must be evaluated only once.  */
7189   gnu_expr = gnat_protect_expr (gnu_expr);
7190
7191   /* Must do this computation in the base type in case the expression's
7192      type is an unsigned subtypes.  */
7193   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
7194
7195   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
7196      the object we are handling.  */
7197   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
7198   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
7199
7200   return emit_check
7201     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7202                       build_binary_op (LT_EXPR, boolean_type_node,
7203                                        gnu_expr_check,
7204                                        convert (TREE_TYPE (gnu_expr_check),
7205                                                 gnu_low)),
7206                       build_binary_op (GT_EXPR, boolean_type_node,
7207                                        gnu_expr_check,
7208                                        convert (TREE_TYPE (gnu_expr_check),
7209                                                 gnu_high))),
7210      gnu_expr, CE_Index_Check_Failed, gnat_node);
7211 }
7212 \f
7213 /* GNU_COND contains the condition corresponding to an access, discriminant or
7214    range check of value GNU_EXPR.  Build a COND_EXPR that returns GNU_EXPR if
7215    GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
7216    REASON is the code that says why the exception was raised.  GNAT_NODE is
7217    the GNAT node conveying the source location for which the error should be
7218    signaled.  */
7219
7220 static tree
7221 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
7222 {
7223   tree gnu_call
7224     = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
7225   tree gnu_result
7226     = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
7227                    build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
7228                            convert (TREE_TYPE (gnu_expr), integer_zero_node)),
7229                    gnu_expr);
7230
7231   /* GNU_RESULT has side effects if and only if GNU_EXPR has:
7232      we don't need to evaluate it just for the check.  */
7233   TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
7234
7235   return gnu_result;
7236 }
7237 \f
7238 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
7239    checks if OVERFLOW_P is true and range checks if RANGE_P is true.
7240    GNAT_TYPE is known to be an integral type.  If TRUNCATE_P true, do a
7241    float to integer conversion with truncation; otherwise round.
7242    GNAT_NODE is the GNAT node conveying the source location for which the
7243    error should be signaled.  */
7244
7245 static tree
7246 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
7247                     bool rangep, bool truncatep, Node_Id gnat_node)
7248 {
7249   tree gnu_type = get_unpadded_type (gnat_type);
7250   tree gnu_in_type = TREE_TYPE (gnu_expr);
7251   tree gnu_in_basetype = get_base_type (gnu_in_type);
7252   tree gnu_base_type = get_base_type (gnu_type);
7253   tree gnu_result = gnu_expr;
7254
7255   /* If we are not doing any checks, the output is an integral type, and
7256      the input is not a floating type, just do the conversion.  This
7257      shortcut is required to avoid problems with packed array types
7258      and simplifies code in all cases anyway.   */
7259   if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
7260       && !FLOAT_TYPE_P (gnu_in_type))
7261     return convert (gnu_type, gnu_expr);
7262
7263   /* First convert the expression to its base type.  This
7264      will never generate code, but makes the tests below much simpler.
7265      But don't do this if converting from an integer type to an unconstrained
7266      array type since then we need to get the bounds from the original
7267      (unpacked) type.  */
7268   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
7269     gnu_result = convert (gnu_in_basetype, gnu_result);
7270
7271   /* If overflow checks are requested,  we need to be sure the result will
7272      fit in the output base type.  But don't do this if the input
7273      is integer and the output floating-point.  */
7274   if (overflowp
7275       && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
7276     {
7277       /* Ensure GNU_EXPR only gets evaluated once.  */
7278       tree gnu_input = gnat_protect_expr (gnu_result);
7279       tree gnu_cond = boolean_false_node;
7280       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
7281       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
7282       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
7283       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
7284
7285       /* Convert the lower bounds to signed types, so we're sure we're
7286          comparing them properly.  Likewise, convert the upper bounds
7287          to unsigned types.  */
7288       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
7289         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
7290
7291       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7292           && !TYPE_UNSIGNED (gnu_in_basetype))
7293         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
7294
7295       if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
7296         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
7297
7298       if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
7299         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
7300
7301       /* Check each bound separately and only if the result bound
7302          is tighter than the bound on the input type.  Note that all the
7303          types are base types, so the bounds must be constant. Also,
7304          the comparison is done in the base type of the input, which
7305          always has the proper signedness.  First check for input
7306          integer (which means output integer), output float (which means
7307          both float), or mixed, in which case we always compare.
7308          Note that we have to do the comparison which would *fail* in the
7309          case of an error since if it's an FP comparison and one of the
7310          values is a NaN or Inf, the comparison will fail.  */
7311       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7312           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
7313           : (FLOAT_TYPE_P (gnu_base_type)
7314              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
7315                                  TREE_REAL_CST (gnu_out_lb))
7316              : 1))
7317         gnu_cond
7318           = invert_truthvalue
7319             (build_binary_op (GE_EXPR, boolean_type_node,
7320                               gnu_input, convert (gnu_in_basetype,
7321                                                   gnu_out_lb)));
7322
7323       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7324           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
7325           : (FLOAT_TYPE_P (gnu_base_type)
7326              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
7327                                  TREE_REAL_CST (gnu_in_lb))
7328              : 1))
7329         gnu_cond
7330           = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
7331                              invert_truthvalue
7332                              (build_binary_op (LE_EXPR, boolean_type_node,
7333                                                gnu_input,
7334                                                convert (gnu_in_basetype,
7335                                                         gnu_out_ub))));
7336
7337       if (!integer_zerop (gnu_cond))
7338         gnu_result = emit_check (gnu_cond, gnu_input,
7339                                  CE_Overflow_Check_Failed, gnat_node);
7340     }
7341
7342   /* Now convert to the result base type.  If this is a non-truncating
7343      float-to-integer conversion, round.  */
7344   if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
7345       && !truncatep)
7346     {
7347       REAL_VALUE_TYPE half_minus_pred_half, pred_half;
7348       tree gnu_conv, gnu_zero, gnu_comp, calc_type;
7349       tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
7350       const struct real_format *fmt;
7351
7352       /* The following calculations depend on proper rounding to even
7353          of each arithmetic operation. In order to prevent excess
7354          precision from spoiling this property, use the widest hardware
7355          floating-point type if FP_ARITH_MAY_WIDEN is true.  */
7356       calc_type
7357         = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
7358
7359       /* FIXME: Should not have padding in the first place.  */
7360       if (TYPE_IS_PADDING_P (calc_type))
7361         calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
7362
7363       /* Compute the exact value calc_type'Pred (0.5) at compile time.  */
7364       fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
7365       real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
7366       REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
7367                        half_minus_pred_half);
7368       gnu_pred_half = build_real (calc_type, pred_half);
7369
7370       /* If the input is strictly negative, subtract this value
7371          and otherwise add it from the input.  For 0.5, the result
7372          is exactly between 1.0 and the machine number preceding 1.0
7373          (for calc_type).  Since the last bit of 1.0 is even, this 0.5
7374          will round to 1.0, while all other number with an absolute
7375          value less than 0.5 round to 0.0.  For larger numbers exactly
7376          halfway between integers, rounding will always be correct as
7377          the true mathematical result will be closer to the higher
7378          integer compared to the lower one.  So, this constant works
7379          for all floating-point numbers.
7380
7381          The reason to use the same constant with subtract/add instead
7382          of a positive and negative constant is to allow the comparison
7383          to be scheduled in parallel with retrieval of the constant and
7384          conversion of the input to the calc_type (if necessary).  */
7385
7386       gnu_zero = convert (gnu_in_basetype, integer_zero_node);
7387       gnu_result = gnat_protect_expr (gnu_result);
7388       gnu_conv = convert (calc_type, gnu_result);
7389       gnu_comp
7390         = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
7391       gnu_add_pred_half
7392         = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
7393       gnu_subtract_pred_half
7394         = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
7395       gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
7396                                 gnu_add_pred_half, gnu_subtract_pred_half);
7397     }
7398
7399   if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
7400       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
7401       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
7402     gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
7403   else
7404     gnu_result = convert (gnu_base_type, gnu_result);
7405
7406   /* Finally, do the range check if requested.  Note that if the result type
7407      is a modular type, the range check is actually an overflow check.  */
7408   if (rangep
7409       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
7410           && TYPE_MODULAR_P (gnu_base_type) && overflowp))
7411     gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
7412
7413   return convert (gnu_type, gnu_result);
7414 }
7415 \f
7416 /* Return true if GNU_EXPR can be directly addressed.  This is the case
7417    unless it is an expression involving computation or if it involves a
7418    reference to a bitfield or to an object not sufficiently aligned for
7419    its type.  If GNU_TYPE is non-null, return true only if GNU_EXPR can
7420    be directly addressed as an object of this type.
7421
7422    *** Notes on addressability issues in the Ada compiler ***
7423
7424    This predicate is necessary in order to bridge the gap between Gigi
7425    and the middle-end about addressability of GENERIC trees.  A tree
7426    is said to be addressable if it can be directly addressed, i.e. if
7427    its address can be taken, is a multiple of the type's alignment on
7428    strict-alignment architectures and returns the first storage unit
7429    assigned to the object represented by the tree.
7430
7431    In the C family of languages, everything is in practice addressable
7432    at the language level, except for bit-fields.  This means that these
7433    compilers will take the address of any tree that doesn't represent
7434    a bit-field reference and expect the result to be the first storage
7435    unit assigned to the object.  Even in cases where this will result
7436    in unaligned accesses at run time, nothing is supposed to be done
7437    and the program is considered as erroneous instead (see PR c/18287).
7438
7439    The implicit assumptions made in the middle-end are in keeping with
7440    the C viewpoint described above:
7441      - the address of a bit-field reference is supposed to be never
7442        taken; the compiler (generally) will stop on such a construct,
7443      - any other tree is addressable if it is formally addressable,
7444        i.e. if it is formally allowed to be the operand of ADDR_EXPR.
7445
7446    In Ada, the viewpoint is the opposite one: nothing is addressable
7447    at the language level unless explicitly declared so.  This means
7448    that the compiler will both make sure that the trees representing
7449    references to addressable ("aliased" in Ada parlance) objects are
7450    addressable and make no real attempts at ensuring that the trees
7451    representing references to non-addressable objects are addressable.
7452
7453    In the first case, Ada is effectively equivalent to C and handing
7454    down the direct result of applying ADDR_EXPR to these trees to the
7455    middle-end works flawlessly.  In the second case, Ada cannot afford
7456    to consider the program as erroneous if the address of trees that
7457    are not addressable is requested for technical reasons, unlike C;
7458    as a consequence, the Ada compiler must arrange for either making
7459    sure that this address is not requested in the middle-end or for
7460    compensating by inserting temporaries if it is requested in Gigi.
7461
7462    The first goal can be achieved because the middle-end should not
7463    request the address of non-addressable trees on its own; the only
7464    exception is for the invocation of low-level block operations like
7465    memcpy, for which the addressability requirements are lower since
7466    the type's alignment can be disregarded.  In practice, this means
7467    that Gigi must make sure that such operations cannot be applied to
7468    non-BLKmode bit-fields.
7469
7470    The second goal is achieved by means of the addressable_p predicate,
7471    which computes whether a temporary must be inserted by Gigi when the
7472    address of a tree is requested; if so, the address of the temporary
7473    will be used in lieu of that of the original tree and some glue code
7474    generated to connect everything together.  */
7475
7476 static bool
7477 addressable_p (tree gnu_expr, tree gnu_type)
7478 {
7479   /* For an integral type, the size of the actual type of the object may not
7480      be greater than that of the expected type, otherwise an indirect access
7481      in the latter type wouldn't correctly set all the bits of the object.  */
7482   if (gnu_type
7483       && INTEGRAL_TYPE_P (gnu_type)
7484       && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
7485     return false;
7486
7487   /* The size of the actual type of the object may not be smaller than that
7488      of the expected type, otherwise an indirect access in the latter type
7489      would be larger than the object.  But only record types need to be
7490      considered in practice for this case.  */
7491   if (gnu_type
7492       && TREE_CODE (gnu_type) == RECORD_TYPE
7493       && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
7494     return false;
7495
7496   switch (TREE_CODE (gnu_expr))
7497     {
7498     case VAR_DECL:
7499     case PARM_DECL:
7500     case FUNCTION_DECL:
7501     case RESULT_DECL:
7502       /* All DECLs are addressable: if they are in a register, we can force
7503          them to memory.  */
7504       return true;
7505
7506     case UNCONSTRAINED_ARRAY_REF:
7507     case INDIRECT_REF:
7508       /* Taking the address of a dereference yields the original pointer.  */
7509       return true;
7510
7511     case STRING_CST:
7512     case INTEGER_CST:
7513       /* Taking the address yields a pointer to the constant pool.  */
7514       return true;
7515
7516     case CONSTRUCTOR:
7517       /* Taking the address of a static constructor yields a pointer to the
7518          tree constant pool.  */
7519       return TREE_STATIC (gnu_expr) ? true : false;
7520
7521     case NULL_EXPR:
7522     case SAVE_EXPR:
7523     case CALL_EXPR:
7524     case PLUS_EXPR:
7525     case MINUS_EXPR:
7526     case BIT_IOR_EXPR:
7527     case BIT_XOR_EXPR:
7528     case BIT_AND_EXPR:
7529     case BIT_NOT_EXPR:
7530       /* All rvalues are deemed addressable since taking their address will
7531          force a temporary to be created by the middle-end.  */
7532       return true;
7533
7534     case COMPOUND_EXPR:
7535       /* The address of a compound expression is that of its 2nd operand.  */
7536       return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
7537
7538     case COND_EXPR:
7539       /* We accept &COND_EXPR as soon as both operands are addressable and
7540          expect the outcome to be the address of the selected operand.  */
7541       return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
7542               && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
7543
7544     case COMPONENT_REF:
7545       return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
7546                 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
7547                    the field is sufficiently aligned, in case it is subject
7548                    to a pragma Component_Alignment.  But we don't need to
7549                    check the alignment of the containing record, as it is
7550                    guaranteed to be not smaller than that of its most
7551                    aligned field that is not a bit-field.  */
7552                 && (!STRICT_ALIGNMENT
7553                     || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
7554                        >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
7555                /* The field of a padding record is always addressable.  */
7556                || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
7557               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7558
7559     case ARRAY_REF:  case ARRAY_RANGE_REF:
7560     case REALPART_EXPR:  case IMAGPART_EXPR:
7561     case NOP_EXPR:
7562       return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
7563
7564     case CONVERT_EXPR:
7565       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
7566               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7567
7568     case VIEW_CONVERT_EXPR:
7569       {
7570         /* This is addressable if we can avoid a copy.  */
7571         tree type = TREE_TYPE (gnu_expr);
7572         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
7573         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
7574                   && (!STRICT_ALIGNMENT
7575                       || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7576                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
7577                  || ((TYPE_MODE (type) == BLKmode
7578                       || TYPE_MODE (inner_type) == BLKmode)
7579                      && (!STRICT_ALIGNMENT
7580                          || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7581                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
7582                          || TYPE_ALIGN_OK (type)
7583                          || TYPE_ALIGN_OK (inner_type))))
7584                 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7585       }
7586
7587     default:
7588       return false;
7589     }
7590 }
7591 \f
7592 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
7593    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
7594    make a GCC type for GNAT_ENTITY and set up the correspondence.  */
7595
7596 void
7597 process_type (Entity_Id gnat_entity)
7598 {
7599   tree gnu_old
7600     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
7601   tree gnu_new;
7602
7603   /* If we are to delay elaboration of this type, just do any
7604      elaborations needed for expressions within the declaration and
7605      make a dummy type entry for this node and its Full_View (if
7606      any) in case something points to it.  Don't do this if it
7607      has already been done (the only way that can happen is if
7608      the private completion is also delayed).  */
7609   if (Present (Freeze_Node (gnat_entity))
7610       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7611           && Present (Full_View (gnat_entity))
7612           && Freeze_Node (Full_View (gnat_entity))
7613           && !present_gnu_tree (Full_View (gnat_entity))))
7614     {
7615       elaborate_entity (gnat_entity);
7616
7617       if (!gnu_old)
7618         {
7619           tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
7620           save_gnu_tree (gnat_entity, gnu_decl, false);
7621           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7622               && Present (Full_View (gnat_entity)))
7623             {
7624               if (Has_Completion_In_Body (gnat_entity))
7625                 DECL_TAFT_TYPE_P (gnu_decl) = 1;
7626               save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
7627             }
7628         }
7629
7630       return;
7631     }
7632
7633   /* If we saved away a dummy type for this node it means that this
7634      made the type that corresponds to the full type of an incomplete
7635      type.  Clear that type for now and then update the type in the
7636      pointers.  */
7637   if (gnu_old)
7638     {
7639       gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
7640                   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
7641
7642       save_gnu_tree (gnat_entity, NULL_TREE, false);
7643     }
7644
7645   /* Now fully elaborate the type.  */
7646   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
7647   gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
7648
7649   /* If we have an old type and we've made pointers to this type, update those
7650      pointers.  If this is a Taft amendment type in the main unit, we need to
7651      mark the type as used since other units referencing it don't see the full
7652      declaration and, therefore, cannot mark it as used themselves.  */
7653   if (gnu_old)
7654     {
7655       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
7656                          TREE_TYPE (gnu_new));
7657       if (DECL_TAFT_TYPE_P (gnu_old))
7658         used_types_insert (TREE_TYPE (gnu_new));
7659     }
7660
7661   /* If this is a record type corresponding to a task or protected type
7662      that is a completion of an incomplete type, perform a similar update
7663      on the type.  ??? Including protected types here is a guess.  */
7664   if (IN (Ekind (gnat_entity), Record_Kind)
7665       && Is_Concurrent_Record_Type (gnat_entity)
7666       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
7667     {
7668       tree gnu_task_old
7669         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
7670
7671       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7672                      NULL_TREE, false);
7673       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7674                      gnu_new, false);
7675
7676       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
7677                          TREE_TYPE (gnu_new));
7678     }
7679 }
7680 \f
7681 /* GNAT_ENTITY is the type of the resulting constructors,
7682    GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
7683    and GNU_TYPE is the GCC type of the corresponding record.
7684
7685    Return a CONSTRUCTOR to build the record.  */
7686
7687 static tree
7688 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
7689 {
7690   tree gnu_list, gnu_result;
7691
7692   /* We test for GNU_FIELD being empty in the case where a variant
7693      was the last thing since we don't take things off GNAT_ASSOC in
7694      that case.  We check GNAT_ASSOC in case we have a variant, but it
7695      has no fields.  */
7696
7697   for (gnu_list = NULL_TREE; Present (gnat_assoc);
7698        gnat_assoc = Next (gnat_assoc))
7699     {
7700       Node_Id gnat_field = First (Choices (gnat_assoc));
7701       tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
7702       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
7703
7704       /* The expander is supposed to put a single component selector name
7705          in every record component association.  */
7706       gcc_assert (No (Next (gnat_field)));
7707
7708       /* Ignore fields that have Corresponding_Discriminants since we'll
7709          be setting that field in the parent.  */
7710       if (Present (Corresponding_Discriminant (Entity (gnat_field)))
7711           && Is_Tagged_Type (Scope (Entity (gnat_field))))
7712         continue;
7713
7714       /* Also ignore discriminants of Unchecked_Unions.  */
7715       else if (Is_Unchecked_Union (gnat_entity)
7716                && Ekind (Entity (gnat_field)) == E_Discriminant)
7717         continue;
7718
7719       /* Before assigning a value in an aggregate make sure range checks
7720          are done if required.  Then convert to the type of the field.  */
7721       if (Do_Range_Check (Expression (gnat_assoc)))
7722         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
7723
7724       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
7725
7726       /* Add the field and expression to the list.  */
7727       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
7728     }
7729
7730   gnu_result = extract_values (gnu_list, gnu_type);
7731
7732 #ifdef ENABLE_CHECKING
7733   {
7734     tree gnu_field;
7735
7736     /* Verify every entry in GNU_LIST was used.  */
7737     for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
7738       gcc_assert (TREE_ADDRESSABLE (gnu_field));
7739   }
7740 #endif
7741
7742   return gnu_result;
7743 }
7744
7745 /* Build a possibly nested constructor for array aggregates.  GNAT_EXPR is
7746    the first element of an array aggregate.  It may itself be an aggregate.
7747    GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
7748    GNAT_COMPONENT_TYPE is the type of the array component; it is needed
7749    for range checking.  */
7750
7751 static tree
7752 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
7753                     Entity_Id gnat_component_type)
7754 {
7755   tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
7756   tree gnu_expr;
7757   VEC(constructor_elt,gc) *gnu_expr_vec = NULL;
7758
7759   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
7760     {
7761       /* If the expression is itself an array aggregate then first build the
7762          innermost constructor if it is part of our array (multi-dimensional
7763          case).  */
7764       if (Nkind (gnat_expr) == N_Aggregate
7765           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
7766           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
7767         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
7768                                        TREE_TYPE (gnu_array_type),
7769                                        gnat_component_type);
7770       else
7771         {
7772           gnu_expr = gnat_to_gnu (gnat_expr);
7773
7774           /* Before assigning the element to the array, make sure it is
7775              in range.  */
7776           if (Do_Range_Check (gnat_expr))
7777             gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
7778         }
7779
7780       CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
7781                               convert (TREE_TYPE (gnu_array_type), gnu_expr));
7782
7783       gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node);
7784     }
7785
7786   return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
7787 }
7788 \f
7789 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
7790    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
7791    of the associations that are from RECORD_TYPE.  If we see an internal
7792    record, make a recursive call to fill it in as well.  */
7793
7794 static tree
7795 extract_values (tree values, tree record_type)
7796 {
7797   tree field, tem;
7798   VEC(constructor_elt,gc) *v = NULL;
7799
7800   for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
7801     {
7802       tree value = 0;
7803
7804       /* _Parent is an internal field, but may have values in the aggregate,
7805          so check for values first.  */
7806       if ((tem = purpose_member (field, values)))
7807         {
7808           value = TREE_VALUE (tem);
7809           TREE_ADDRESSABLE (tem) = 1;
7810         }
7811
7812       else if (DECL_INTERNAL_P (field))
7813         {
7814           value = extract_values (values, TREE_TYPE (field));
7815           if (TREE_CODE (value) == CONSTRUCTOR
7816               && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
7817             value = 0;
7818         }
7819       else
7820         /* If we have a record subtype, the names will match, but not the
7821            actual FIELD_DECLs.  */
7822         for (tem = values; tem; tem = TREE_CHAIN (tem))
7823           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
7824             {
7825               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
7826               TREE_ADDRESSABLE (tem) = 1;
7827             }
7828
7829       if (!value)
7830         continue;
7831
7832       CONSTRUCTOR_APPEND_ELT (v, field, value);
7833     }
7834
7835   return gnat_build_constructor (record_type, v);
7836 }
7837 \f
7838 /* EXP is to be treated as an array or record.  Handle the cases when it is
7839    an access object and perform the required dereferences.  */
7840
7841 static tree
7842 maybe_implicit_deref (tree exp)
7843 {
7844   /* If the type is a pointer, dereference it.  */
7845   if (POINTER_TYPE_P (TREE_TYPE (exp))
7846       || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
7847     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
7848
7849   /* If we got a padded type, remove it too.  */
7850   if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
7851     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
7852
7853   return exp;
7854 }
7855 \f
7856 /* Convert SLOC into LOCUS.  Return true if SLOC corresponds to a source code
7857    location and false if it doesn't.  In the former case, set the Gigi global
7858    variable REF_FILENAME to the simple debug file name as given by sinput.  */
7859
7860 bool
7861 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
7862 {
7863   if (Sloc == No_Location)
7864     return false;
7865
7866   if (Sloc <= Standard_Location)
7867     {
7868       *locus = BUILTINS_LOCATION;
7869       return false;
7870     }
7871   else
7872     {
7873       Source_File_Index file = Get_Source_File_Index (Sloc);
7874       Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
7875       Column_Number column = Get_Column_Number (Sloc);
7876       struct line_map *map = &line_table->maps[file - 1];
7877
7878       /* Translate the location according to the line-map.h formula.  */
7879       *locus = map->start_location
7880                 + ((line - map->to_line) << map->column_bits)
7881                 + (column & ((1 << map->column_bits) - 1));
7882     }
7883
7884   ref_filename
7885     = IDENTIFIER_POINTER
7886       (get_identifier
7887        (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
7888
7889   return true;
7890 }
7891
7892 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
7893    don't do anything if it doesn't correspond to a source location.  */
7894
7895 static void
7896 set_expr_location_from_node (tree node, Node_Id gnat_node)
7897 {
7898   location_t locus;
7899
7900   if (!Sloc_to_locus (Sloc (gnat_node), &locus))
7901     return;
7902
7903   SET_EXPR_LOCATION (node, locus);
7904 }
7905
7906 /* More elaborate version of set_expr_location_from_node to be used in more
7907    general contexts, for example the result of the translation of a generic
7908    GNAT node.  */
7909
7910 static void
7911 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
7912 {
7913   /* Set the location information on the node if it is a real expression.
7914      References can be reused for multiple GNAT nodes and they would get
7915      the location information of their last use.  Also make sure not to
7916      overwrite an existing location as it is probably more precise.  */
7917
7918   switch (TREE_CODE (node))
7919     {
7920     CASE_CONVERT:
7921     case NON_LVALUE_EXPR:
7922       break;
7923
7924     case COMPOUND_EXPR:
7925       if (EXPR_P (TREE_OPERAND (node, 1)))
7926         set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
7927
7928       /* ... fall through ... */
7929
7930     default:
7931       if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
7932         {
7933           set_expr_location_from_node (node, gnat_node);
7934           set_end_locus_from_node (node, gnat_node);
7935         }
7936       break;
7937     }
7938 }
7939 \f
7940 /* Return a colon-separated list of encodings contained in encoded Ada
7941    name.  */
7942
7943 static const char *
7944 extract_encoding (const char *name)
7945 {
7946   char *encoding = (char *) ggc_alloc_atomic (strlen (name));
7947   get_encoding (name, encoding);
7948   return encoding;
7949 }
7950
7951 /* Extract the Ada name from an encoded name.  */
7952
7953 static const char *
7954 decode_name (const char *name)
7955 {
7956   char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
7957   __gnat_decode (name, decoded, 0);
7958   return decoded;
7959 }
7960 \f
7961 /* Post an error message.  MSG is the error message, properly annotated.
7962    NODE is the node at which to post the error and the node to use for the
7963    '&' substitution.  */
7964
7965 void
7966 post_error (const char *msg, Node_Id node)
7967 {
7968   String_Template temp;
7969   Fat_Pointer fp;
7970
7971   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7972   fp.Array = msg, fp.Bounds = &temp;
7973   if (Present (node))
7974     Error_Msg_N (fp, node);
7975 }
7976
7977 /* Similar to post_error, but NODE is the node at which to post the error and
7978    ENT is the node to use for the '&' substitution.  */
7979
7980 void
7981 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
7982 {
7983   String_Template temp;
7984   Fat_Pointer fp;
7985
7986   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7987   fp.Array = msg, fp.Bounds = &temp;
7988   if (Present (node))
7989     Error_Msg_NE (fp, node, ent);
7990 }
7991
7992 /* Similar to post_error_ne, but NUM is the number to use for the '^'.  */
7993
7994 void
7995 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
7996 {
7997   Error_Msg_Uint_1 = UI_From_Int (num);
7998   post_error_ne (msg, node, ent);
7999 }
8000
8001 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
8002    location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
8003    most sense.  Return true if a sensible assignment was performed.  */
8004
8005 static bool
8006 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
8007 {
8008   Node_Id gnat_end_label = Empty;
8009   location_t end_locus;
8010
8011   /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
8012      end_locus when there is one.  We consider only GNAT nodes with a possible
8013      End_Label attached.  If the End_Label actually was unassigned, fallback
8014      on the orginal node.  We'd better assign an explicit sloc associated with
8015      the outer construct in any case.  */
8016
8017   switch (Nkind (gnat_node))
8018     {
8019     case N_Package_Body:
8020     case N_Subprogram_Body:
8021     case N_Block_Statement:
8022       gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
8023       break;
8024
8025     case N_Package_Declaration:
8026       gnat_end_label = End_Label (Specification (gnat_node));
8027       break;
8028
8029     default:
8030       return false;
8031     }
8032
8033   gnat_node = Present (gnat_end_label) ? gnat_end_label : gnat_node;
8034
8035   /* Some expanded subprograms have neither an End_Label nor a Sloc
8036      attached.  Notify that to callers.  */
8037
8038   if (!Sloc_to_locus (Sloc (gnat_node), &end_locus))
8039     return false;
8040
8041   switch (TREE_CODE (gnu_node))
8042     {
8043     case BIND_EXPR:
8044       BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
8045       return true;
8046
8047     case FUNCTION_DECL:
8048       DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
8049       return true;
8050
8051     default:
8052       return false;
8053     }
8054 }
8055 \f
8056 /* Similar to post_error_ne, but T is a GCC tree representing the number to
8057    write.  If T represents a constant, the text inside curly brackets in
8058    MSG will be output (presumably including a '^').  Otherwise it will not
8059    be output and the text inside square brackets will be output instead.  */
8060
8061 void
8062 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
8063 {
8064   char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
8065   char start_yes, end_yes, start_no, end_no;
8066   const char *p;
8067   char *q;
8068
8069   if (TREE_CODE (t) == INTEGER_CST)
8070     {
8071       Error_Msg_Uint_1 = UI_From_gnu (t);
8072       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
8073     }
8074   else
8075     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
8076
8077   for (p = msg, q = new_msg; *p; p++)
8078     {
8079       if (*p == start_yes)
8080         for (p++; *p != end_yes; p++)
8081           *q++ = *p;
8082       else if (*p == start_no)
8083         for (p++; *p != end_no; p++)
8084           ;
8085       else
8086         *q++ = *p;
8087     }
8088
8089   *q = 0;
8090
8091   post_error_ne (new_msg, node, ent);
8092 }
8093
8094 /* Similar to post_error_ne_tree, but NUM is a second integer to write.  */
8095
8096 void
8097 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
8098                       int num)
8099 {
8100   Error_Msg_Uint_2 = UI_From_Int (num);
8101   post_error_ne_tree (msg, node, ent, t);
8102 }
8103 \f
8104 /* Initialize the table that maps GNAT codes to GCC codes for simple
8105    binary and unary operations.  */
8106
8107 static void
8108 init_code_table (void)
8109 {
8110   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
8111   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
8112
8113   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
8114   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
8115   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
8116   gnu_codes[N_Op_Eq] = EQ_EXPR;
8117   gnu_codes[N_Op_Ne] = NE_EXPR;
8118   gnu_codes[N_Op_Lt] = LT_EXPR;
8119   gnu_codes[N_Op_Le] = LE_EXPR;
8120   gnu_codes[N_Op_Gt] = GT_EXPR;
8121   gnu_codes[N_Op_Ge] = GE_EXPR;
8122   gnu_codes[N_Op_Add] = PLUS_EXPR;
8123   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
8124   gnu_codes[N_Op_Multiply] = MULT_EXPR;
8125   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
8126   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
8127   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
8128   gnu_codes[N_Op_Abs] = ABS_EXPR;
8129   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
8130   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
8131   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
8132   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
8133   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
8134   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
8135 }
8136
8137 /* Return a label to branch to for the exception type in KIND or NULL_TREE
8138    if none.  */
8139
8140 tree
8141 get_exception_label (char kind)
8142 {
8143   if (kind == N_Raise_Constraint_Error)
8144     return VEC_last (tree, gnu_constraint_error_label_stack);
8145   else if (kind == N_Raise_Storage_Error)
8146     return VEC_last (tree, gnu_storage_error_label_stack);
8147   else if (kind == N_Raise_Program_Error)
8148     return VEC_last (tree, gnu_program_error_label_stack);
8149   else
8150     return NULL_TREE;
8151 }
8152
8153 /* Return the decl for the current elaboration procedure.  */
8154
8155 tree
8156 get_elaboration_procedure (void)
8157 {
8158   return VEC_last (tree, gnu_elab_proc_stack);
8159 }
8160
8161 #include "gt-ada-trans.h"