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