gcc/ada/gcc-interface/trans.c

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