gcc/ada/gcc-interface/trans.c

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