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