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