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