gcc/ada/gcc-interface/trans.c

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