gcc/ada/gcc-interface/trans.c

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