gcc/ada/gcc-interface/trans.c

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