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