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