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