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