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