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