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