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