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