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 overflows, raise constraint error.  */
5303   else if (TREE_CODE (gnu_result) == INTEGER_CST
5304       && TREE_OVERFLOW (gnu_result))
5305     {
5306       post_error ("Constraint_Error will be raised at run-time?", gnat_node);
5307
5308       gnu_result
5309         = build1 (NULL_EXPR, gnu_result_type,
5310                   build_call_raise (CE_Overflow_Check_Failed, gnat_node,
5311                                     N_Raise_Constraint_Error));
5312     }
5313
5314   /* If our result has side-effects and is of an unconstrained type,
5315      make a SAVE_EXPR so that we can be sure it will only be referenced
5316      once.  Note we must do this before any conversions.  */
5317   if (TREE_SIDE_EFFECTS (gnu_result)
5318       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
5319           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
5320     gnu_result = gnat_stabilize_reference (gnu_result, false);
5321
5322   /* Now convert the result to the result type, unless we are in one of the
5323      following cases:
5324
5325        1. If this is the Name of an assignment statement or a parameter of
5326           a procedure call, return the result almost unmodified since the
5327           RHS will have to be converted to our type in that case, unless
5328           the result type has a simpler size.  Likewise if there is just
5329           a no-op unchecked conversion in-between.  Similarly, don't convert
5330           integral types that are the operands of an unchecked conversion
5331           since we need to ignore those conversions (for 'Valid).
5332
5333        2. If we have a label (which doesn't have any well-defined type), a
5334           field or an error, return the result almost unmodified.  Also don't
5335           do the conversion if the result type involves a PLACEHOLDER_EXPR in
5336           its size since those are the cases where the front end may have the
5337           type wrong due to "instantiating" the unconstrained record with
5338           discriminant values.  Similarly, if the two types are record types
5339           with the same name don't convert.  This will be the case when we are
5340           converting from a packable version of a type to its original type and
5341           we need those conversions to be NOPs in order for assignments into
5342           these types to work properly.
5343
5344        3. If the type is void or if we have no result, return error_mark_node
5345           to show we have no result.
5346
5347        4. Finally, if the type of the result is already correct.  */
5348
5349   if (Present (Parent (gnat_node))
5350       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
5351            && Name (Parent (gnat_node)) == gnat_node)
5352           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
5353               && unchecked_conversion_lhs_nop (Parent (gnat_node)))
5354           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
5355               && Name (Parent (gnat_node)) != gnat_node)
5356           || Nkind (Parent (gnat_node)) == N_Parameter_Association
5357           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
5358               && !AGGREGATE_TYPE_P (gnu_result_type)
5359               && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
5360       && !(TYPE_SIZE (gnu_result_type)
5361            && TYPE_SIZE (TREE_TYPE (gnu_result))
5362            && (AGGREGATE_TYPE_P (gnu_result_type)
5363                == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
5364            && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
5365                 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
5366                     != INTEGER_CST))
5367                || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
5368                    && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
5369                    && (CONTAINS_PLACEHOLDER_P
5370                        (TYPE_SIZE (TREE_TYPE (gnu_result))))))
5371            && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
5372                 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
5373     {
5374       /* Remove padding only if the inner object is of self-referential
5375          size: in that case it must be an object of unconstrained type
5376          with a default discriminant and we want to avoid copying too
5377          much data.  */
5378       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
5379           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
5380           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
5381                                      (TREE_TYPE (gnu_result))))))
5382         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
5383                               gnu_result);
5384     }
5385
5386   else if (TREE_CODE (gnu_result) == LABEL_DECL
5387            || TREE_CODE (gnu_result) == FIELD_DECL
5388            || TREE_CODE (gnu_result) == ERROR_MARK
5389            || (TYPE_SIZE (gnu_result_type)
5390                && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
5391                && TREE_CODE (gnu_result) != INDIRECT_REF
5392                && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
5393            || ((TYPE_NAME (gnu_result_type)
5394                 == TYPE_NAME (TREE_TYPE (gnu_result)))
5395                && TREE_CODE (gnu_result_type) == RECORD_TYPE
5396                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
5397     {
5398       /* Remove any padding.  */
5399       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
5400           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
5401         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
5402                               gnu_result);
5403     }
5404
5405   else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
5406     gnu_result = error_mark_node;
5407
5408   else if (gnu_result_type != TREE_TYPE (gnu_result))
5409     gnu_result = convert (gnu_result_type, gnu_result);
5410
5411   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result.  */
5412   while ((TREE_CODE (gnu_result) == NOP_EXPR
5413           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
5414          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
5415     gnu_result = TREE_OPERAND (gnu_result, 0);
5416
5417   return gnu_result;
5418 }
5419 \f
5420 /* Subroutine of above to push the exception label stack.  GNU_STACK is
5421    a pointer to the stack to update and GNAT_LABEL, if present, is the
5422    label to push onto the stack.  */
5423
5424 static void
5425 push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label)
5426 {
5427   tree gnu_label = (Present (gnat_label)
5428                     ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
5429                     : NULL_TREE);
5430
5431   *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack);
5432 }
5433 \f
5434 /* Record the current code position in GNAT_NODE.  */
5435
5436 static void
5437 record_code_position (Node_Id gnat_node)
5438 {
5439   tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
5440
5441   add_stmt_with_node (stmt_stmt, gnat_node);
5442   save_gnu_tree (gnat_node, stmt_stmt, true);
5443 }
5444
5445 /* Insert the code for GNAT_NODE at the position saved for that node.  */
5446
5447 static void
5448 insert_code_for (Node_Id gnat_node)
5449 {
5450   STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
5451   save_gnu_tree (gnat_node, NULL_TREE, true);
5452 }
5453 \f
5454 /* Start a new statement group chained to the previous group.  */
5455
5456 void
5457 start_stmt_group (void)
5458 {
5459   struct stmt_group *group = stmt_group_free_list;
5460
5461   /* First see if we can get one from the free list.  */
5462   if (group)
5463     stmt_group_free_list = group->previous;
5464   else
5465     group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group));
5466
5467   group->previous = current_stmt_group;
5468   group->stmt_list = group->block = group->cleanups = NULL_TREE;
5469   current_stmt_group = group;
5470 }
5471
5472 /* Add GNU_STMT to the current statement group.  */
5473
5474 void
5475 add_stmt (tree gnu_stmt)
5476 {
5477   append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
5478 }
5479
5480 /* Similar, but set the location of GNU_STMT to that of GNAT_NODE.  */
5481
5482 void
5483 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
5484 {
5485   if (Present (gnat_node))
5486     set_expr_location_from_node (gnu_stmt, gnat_node);
5487   add_stmt (gnu_stmt);
5488 }
5489
5490 /* Add a declaration statement for GNU_DECL to the current statement group.
5491    Get SLOC from Entity_Id.  */
5492
5493 void
5494 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
5495 {
5496   tree type = TREE_TYPE (gnu_decl);
5497   tree gnu_stmt, gnu_init, t;
5498
5499   /* If this is a variable that Gigi is to ignore, we may have been given
5500      an ERROR_MARK.  So test for it.  We also might have been given a
5501      reference for a renaming.  So only do something for a decl.  Also
5502      ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE.  */
5503   if (!DECL_P (gnu_decl)
5504       || (TREE_CODE (gnu_decl) == TYPE_DECL
5505           && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
5506     return;
5507
5508   gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
5509
5510   /* If we are global, we don't want to actually output the DECL_EXPR for
5511      this decl since we already have evaluated the expressions in the
5512      sizes and positions as globals and doing it again would be wrong.  */
5513   if (global_bindings_p ())
5514     {
5515       /* Mark everything as used to prevent node sharing with subprograms.
5516          Note that walk_tree knows how to deal with TYPE_DECL, but neither
5517          VAR_DECL nor CONST_DECL.  This appears to be somewhat arbitrary.  */
5518       mark_visited (&gnu_stmt);
5519       if (TREE_CODE (gnu_decl) == VAR_DECL
5520           || TREE_CODE (gnu_decl) == CONST_DECL)
5521         {
5522           mark_visited (&DECL_SIZE (gnu_decl));
5523           mark_visited (&DECL_SIZE_UNIT (gnu_decl));
5524           mark_visited (&DECL_INITIAL (gnu_decl));
5525         }
5526       /* In any case, we have to deal with our own TYPE_ADA_SIZE field.  */
5527       if (TREE_CODE (gnu_decl) == TYPE_DECL
5528           && (TREE_CODE (type) == RECORD_TYPE
5529               || TREE_CODE (type) == UNION_TYPE
5530               || TREE_CODE (type) == QUAL_UNION_TYPE)
5531           && (t = TYPE_ADA_SIZE (type)))
5532         mark_visited (&t);
5533     }
5534   else
5535     add_stmt_with_node (gnu_stmt, gnat_entity);
5536
5537   /* If this is a variable and an initializer is attached to it, it must be
5538      valid for the context.  Similar to init_const in create_var_decl_1.  */
5539   if (TREE_CODE (gnu_decl) == VAR_DECL
5540       && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
5541       && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
5542           || (TREE_STATIC (gnu_decl)
5543               && !initializer_constant_valid_p (gnu_init,
5544                                                 TREE_TYPE (gnu_init)))))
5545     {
5546       /* If GNU_DECL has a padded type, convert it to the unpadded
5547          type so the assignment is done properly.  */
5548       if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5549         t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
5550       else
5551         t = gnu_decl;
5552
5553       gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, t, gnu_init);
5554
5555       DECL_INITIAL (gnu_decl) = NULL_TREE;
5556       if (TREE_READONLY (gnu_decl))
5557         {
5558           TREE_READONLY (gnu_decl) = 0;
5559           DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
5560         }
5561
5562       add_stmt_with_node (gnu_stmt, gnat_entity);
5563     }
5564 }
5565
5566 /* Callback for walk_tree to mark the visited trees rooted at *TP.  */
5567
5568 static tree
5569 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
5570 {
5571   if (TREE_VISITED (*tp))
5572     *walk_subtrees = 0;
5573
5574   /* Don't mark a dummy type as visited because we want to mark its sizes
5575      and fields once it's filled in.  */
5576   else if (!TYPE_IS_DUMMY_P (*tp))
5577     TREE_VISITED (*tp) = 1;
5578
5579   if (TYPE_P (*tp))
5580     TYPE_SIZES_GIMPLIFIED (*tp) = 1;
5581
5582   return NULL_TREE;
5583 }
5584
5585 /* Utility function to unshare expressions wrapped up in a SAVE_EXPR.  */
5586
5587 static tree
5588 unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
5589                    void *data ATTRIBUTE_UNUSED)
5590 {
5591   tree t = *tp;
5592
5593   if (TREE_CODE (t) == SAVE_EXPR)
5594     TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0));
5595
5596   return NULL_TREE;
5597 }
5598
5599 /* Mark nodes rooted at *TP with TREE_VISITED and types as having their
5600    sized gimplified.  We use this to indicate all variable sizes and
5601    positions in global types may not be shared by any subprogram.  */
5602
5603 void
5604 mark_visited (tree *tp)
5605 {
5606   walk_tree (tp, mark_visited_r, NULL, NULL);
5607 }
5608
5609 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
5610    set its location to that of GNAT_NODE if present.  */
5611
5612 static void
5613 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
5614 {
5615   if (Present (gnat_node))
5616     set_expr_location_from_node (gnu_cleanup, gnat_node);
5617   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
5618 }
5619
5620 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
5621
5622 void
5623 set_block_for_group (tree gnu_block)
5624 {
5625   gcc_assert (!current_stmt_group->block);
5626   current_stmt_group->block = gnu_block;
5627 }
5628
5629 /* Return code corresponding to the current code group.  It is normally
5630    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
5631    BLOCK or cleanups were set.  */
5632
5633 tree
5634 end_stmt_group (void)
5635 {
5636   struct stmt_group *group = current_stmt_group;
5637   tree gnu_retval = group->stmt_list;
5638
5639   /* If this is a null list, allocate a new STATEMENT_LIST.  Then, if there
5640      are cleanups, make a TRY_FINALLY_EXPR.  Last, if there is a BLOCK,
5641      make a BIND_EXPR.  Note that we nest in that because the cleanup may
5642      reference variables in the block.  */
5643   if (gnu_retval == NULL_TREE)
5644     gnu_retval = alloc_stmt_list ();
5645
5646   if (group->cleanups)
5647     gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
5648                          group->cleanups);
5649
5650   if (current_stmt_group->block)
5651     gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
5652                          gnu_retval, group->block);
5653
5654   /* Remove this group from the stack and add it to the free list.  */
5655   current_stmt_group = group->previous;
5656   group->previous = stmt_group_free_list;
5657   stmt_group_free_list = group;
5658
5659   return gnu_retval;
5660 }
5661
5662 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
5663    statements.*/
5664
5665 static void
5666 add_stmt_list (List_Id gnat_list)
5667 {
5668   Node_Id gnat_node;
5669
5670   if (Present (gnat_list))
5671     for (gnat_node = First (gnat_list); Present (gnat_node);
5672          gnat_node = Next (gnat_node))
5673       add_stmt (gnat_to_gnu (gnat_node));
5674 }
5675
5676 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
5677    If BINDING_P is true, push and pop a binding level around the list.  */
5678
5679 static tree
5680 build_stmt_group (List_Id gnat_list, bool binding_p)
5681 {
5682   start_stmt_group ();
5683   if (binding_p)
5684     gnat_pushlevel ();
5685
5686   add_stmt_list (gnat_list);
5687   if (binding_p)
5688     gnat_poplevel ();
5689
5690   return end_stmt_group ();
5691 }
5692 \f
5693 /* Push and pop routines for stacks.  We keep a free list around so we
5694    don't waste tree nodes.  */
5695
5696 static void
5697 push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value)
5698 {
5699   tree gnu_node = gnu_stack_free_list;
5700
5701   if (gnu_node)
5702     {
5703       gnu_stack_free_list = TREE_CHAIN (gnu_node);
5704       TREE_CHAIN (gnu_node) = *gnu_stack_ptr;
5705       TREE_PURPOSE (gnu_node) = gnu_purpose;
5706       TREE_VALUE (gnu_node) = gnu_value;
5707     }
5708   else
5709     gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr);
5710
5711   *gnu_stack_ptr = gnu_node;
5712 }
5713
5714 static void
5715 pop_stack (tree *gnu_stack_ptr)
5716 {
5717   tree gnu_node = *gnu_stack_ptr;
5718
5719   *gnu_stack_ptr = TREE_CHAIN (gnu_node);
5720   TREE_CHAIN (gnu_node) = gnu_stack_free_list;
5721   gnu_stack_free_list = gnu_node;
5722 }
5723 \f
5724 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
5725
5726 int
5727 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
5728                     gimple_seq *post_p ATTRIBUTE_UNUSED)
5729 {
5730   tree expr = *expr_p;
5731   tree op;
5732
5733   if (IS_ADA_STMT (expr))
5734     return gnat_gimplify_stmt (expr_p);
5735
5736   switch (TREE_CODE (expr))
5737     {
5738     case NULL_EXPR:
5739       /* If this is for a scalar, just make a VAR_DECL for it.  If for
5740          an aggregate, get a null pointer of the appropriate type and
5741          dereference it.  */
5742       if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
5743         *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
5744                           convert (build_pointer_type (TREE_TYPE (expr)),
5745                                    integer_zero_node));
5746       else
5747         {
5748           *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
5749           TREE_NO_WARNING (*expr_p) = 1;
5750         }
5751
5752       gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
5753       return GS_OK;
5754
5755     case UNCONSTRAINED_ARRAY_REF:
5756       /* We should only do this if we are just elaborating for side-effects,
5757          but we can't know that yet.  */
5758       *expr_p = TREE_OPERAND (*expr_p, 0);
5759       return GS_OK;
5760
5761     case ADDR_EXPR:
5762       op = TREE_OPERAND (expr, 0);
5763
5764       /* If we're taking the address of a constant CONSTRUCTOR, force it to
5765          be put into static memory.  We know it's going to be readonly given
5766          the semantics we have and it's required to be static memory in
5767          the case when the reference is in an elaboration procedure.   */
5768       if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
5769         {
5770           tree new_var = create_tmp_var (TREE_TYPE (op), "C");
5771
5772           TREE_READONLY (new_var) = 1;
5773           TREE_STATIC (new_var) = 1;
5774           TREE_ADDRESSABLE (new_var) = 1;
5775           DECL_INITIAL (new_var) = op;
5776
5777           TREE_OPERAND (expr, 0) = new_var;
5778           recompute_tree_invariant_for_addr_expr (expr);
5779           return GS_ALL_DONE;
5780         }
5781
5782       /* If we are taking the address of a SAVE_EXPR, we are typically
5783          processing a misaligned argument to be passed by reference in a
5784          procedure call.  We just mark the operand as addressable + not
5785          readonly here and let the common gimplifier code perform the
5786          temporary creation, initialization, and "instantiation" in place of
5787          the SAVE_EXPR in further operands, in particular in the copy back
5788          code inserted after the call.  */
5789       else if (TREE_CODE (op) == SAVE_EXPR)
5790         {
5791           TREE_ADDRESSABLE (op) = 1;
5792           TREE_READONLY (op) = 0;
5793         }
5794
5795       /* We let the gimplifier process &COND_EXPR and expect it to yield the
5796          address of the selected operand when it is addressable.  Besides, we
5797          also expect addressable_p to only let COND_EXPRs where both arms are
5798          addressable reach here.  */
5799       else if (TREE_CODE (op) == COND_EXPR)
5800         ;
5801
5802       /* Otherwise, if we are taking the address of something that is neither
5803          reference, declaration, or constant, make a variable for the operand
5804          here and then take its address.  If we don't do it this way, we may
5805          confuse the gimplifier because it needs to know the variable is
5806          addressable at this point.  This duplicates code in
5807          internal_get_tmp_var, which is unfortunate.  */
5808       else if (TREE_CODE_CLASS (TREE_CODE (op)) != tcc_reference
5809                && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_declaration
5810                && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_constant)
5811         {
5812           tree new_var = create_tmp_var (TREE_TYPE (op), "A");
5813           gimple stmt;
5814
5815           TREE_ADDRESSABLE (new_var) = 1;
5816
5817           stmt = gimplify_assign (new_var, op, pre_p);
5818           if (EXPR_HAS_LOCATION (op))
5819             gimple_set_location (stmt, *EXPR_LOCUS (op));
5820
5821           TREE_OPERAND (expr, 0) = new_var;
5822           recompute_tree_invariant_for_addr_expr (expr);
5823           return GS_ALL_DONE;
5824         }
5825
5826       /* ... fall through ... */
5827
5828     default:
5829       return GS_UNHANDLED;
5830     }
5831 }
5832
5833 /* Generate GIMPLE in place for the statement at *STMT_P.  */
5834
5835 static enum gimplify_status
5836 gnat_gimplify_stmt (tree *stmt_p)
5837 {
5838   tree stmt = *stmt_p;
5839
5840   switch (TREE_CODE (stmt))
5841     {
5842     case STMT_STMT:
5843       *stmt_p = STMT_STMT_STMT (stmt);
5844       return GS_OK;
5845
5846     case LOOP_STMT:
5847       {
5848         tree gnu_start_label = create_artificial_label ();
5849         tree gnu_end_label = LOOP_STMT_LABEL (stmt);
5850         tree t;
5851
5852         /* Set to emit the statements of the loop.  */
5853         *stmt_p = NULL_TREE;
5854
5855         /* We first emit the start label and then a conditional jump to
5856            the end label if there's a top condition, then the body of the
5857            loop, then a conditional branch to the end label, then the update,
5858            if any, and finally a jump to the start label and the definition
5859            of the end label.  */
5860         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
5861                                           gnu_start_label),
5862                                   stmt_p);
5863
5864         if (LOOP_STMT_TOP_COND (stmt))
5865           append_to_statement_list (build3 (COND_EXPR, void_type_node,
5866                                             LOOP_STMT_TOP_COND (stmt),
5867                                             alloc_stmt_list (),
5868                                             build1 (GOTO_EXPR,
5869                                                     void_type_node,
5870                                                     gnu_end_label)),
5871                                     stmt_p);
5872
5873         append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
5874
5875         if (LOOP_STMT_BOT_COND (stmt))
5876           append_to_statement_list (build3 (COND_EXPR, void_type_node,
5877                                             LOOP_STMT_BOT_COND (stmt),
5878                                             alloc_stmt_list (),
5879                                             build1 (GOTO_EXPR,
5880                                                     void_type_node,
5881                                                     gnu_end_label)),
5882                                     stmt_p);
5883
5884         if (LOOP_STMT_UPDATE (stmt))
5885           append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p);
5886
5887         t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
5888         SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
5889         append_to_statement_list (t, stmt_p);
5890
5891         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
5892                                           gnu_end_label),
5893                                   stmt_p);
5894         return GS_OK;
5895       }
5896
5897     case EXIT_STMT:
5898       /* Build a statement to jump to the corresponding end label, then
5899          see if it needs to be conditional.  */
5900       *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
5901       if (EXIT_STMT_COND (stmt))
5902         *stmt_p = build3 (COND_EXPR, void_type_node,
5903                           EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
5904       return GS_OK;
5905
5906     default:
5907       gcc_unreachable ();
5908     }
5909 }
5910 \f
5911 /* Force references to each of the entities in packages withed by GNAT_NODE.
5912    Operate recursively but check that we aren't elaborating something more
5913    than once.
5914
5915    This routine is exclusively called in type_annotate mode, to compute DDA
5916    information for types in withed units, for ASIS use.  */
5917
5918 static void
5919 elaborate_all_entities (Node_Id gnat_node)
5920 {
5921   Entity_Id gnat_with_clause, gnat_entity;
5922
5923   /* Process each unit only once.  As we trace the context of all relevant
5924      units transitively, including generic bodies, we may encounter the
5925      same generic unit repeatedly.  */
5926   if (!present_gnu_tree (gnat_node))
5927      save_gnu_tree (gnat_node, integer_zero_node, true);
5928
5929   /* Save entities in all context units.  A body may have an implicit_with
5930      on its own spec, if the context includes a child unit, so don't save
5931      the spec twice.  */
5932   for (gnat_with_clause = First (Context_Items (gnat_node));
5933        Present (gnat_with_clause);
5934        gnat_with_clause = Next (gnat_with_clause))
5935     if (Nkind (gnat_with_clause) == N_With_Clause
5936         && !present_gnu_tree (Library_Unit (gnat_with_clause))
5937         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
5938       {
5939         elaborate_all_entities (Library_Unit (gnat_with_clause));
5940
5941         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
5942           {
5943             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
5944                  Present (gnat_entity);
5945                  gnat_entity = Next_Entity (gnat_entity))
5946               if (Is_Public (gnat_entity)
5947                   && Convention (gnat_entity) != Convention_Intrinsic
5948                   && Ekind (gnat_entity) != E_Package
5949                   && Ekind (gnat_entity) != E_Package_Body
5950                   && Ekind (gnat_entity) != E_Operator
5951                   && !(IN (Ekind (gnat_entity), Type_Kind)
5952                        && !Is_Frozen (gnat_entity))
5953                   && !((Ekind (gnat_entity) == E_Procedure
5954                         || Ekind (gnat_entity) == E_Function)
5955                        && Is_Intrinsic_Subprogram (gnat_entity))
5956                   && !IN (Ekind (gnat_entity), Named_Kind)
5957                   && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
5958                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5959           }
5960         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
5961           {
5962             Node_Id gnat_body
5963               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
5964
5965             /* Retrieve compilation unit node of generic body.  */
5966             while (Present (gnat_body)
5967                    && Nkind (gnat_body) != N_Compilation_Unit)
5968               gnat_body = Parent (gnat_body);
5969
5970             /* If body is available, elaborate its context.  */
5971             if (Present (gnat_body))
5972               elaborate_all_entities (gnat_body);
5973           }
5974       }
5975
5976   if (Nkind (Unit (gnat_node)) == N_Package_Body)
5977     elaborate_all_entities (Library_Unit (gnat_node));
5978 }
5979 \f
5980 /* Do the processing of N_Freeze_Entity, GNAT_NODE.  */
5981
5982 static void
5983 process_freeze_entity (Node_Id gnat_node)
5984 {
5985   Entity_Id gnat_entity = Entity (gnat_node);
5986   tree gnu_old;
5987   tree gnu_new;
5988   tree gnu_init
5989     = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
5990        && present_gnu_tree (Declaration_Node (gnat_entity)))
5991       ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
5992
5993   /* If this is a package, need to generate code for the package.  */
5994   if (Ekind (gnat_entity) == E_Package)
5995     {
5996       insert_code_for
5997         (Parent (Corresponding_Body
5998                  (Parent (Declaration_Node (gnat_entity)))));
5999       return;
6000     }
6001
6002   /* Check for old definition after the above call.  This Freeze_Node
6003      might be for one its Itypes.  */
6004   gnu_old
6005     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
6006
6007   /* If this entity has an Address representation clause, GNU_OLD is the
6008      address, so discard it here.  */
6009   if (Present (Address_Clause (gnat_entity)))
6010     gnu_old = 0;
6011
6012   /* Don't do anything for class-wide types they are always
6013      transformed into their root type.  */
6014   if (Ekind (gnat_entity) == E_Class_Wide_Type
6015       || (Ekind (gnat_entity) == E_Class_Wide_Subtype
6016           && Present (Equivalent_Type (gnat_entity))))
6017     return;
6018
6019   /* Don't do anything for subprograms that may have been elaborated before
6020      their freeze nodes.  This can happen, for example because of an inner call
6021      in an instance body, or a previous compilation of a spec for inlining
6022      purposes.  */
6023   if (gnu_old
6024       && ((TREE_CODE (gnu_old) == FUNCTION_DECL
6025            && (Ekind (gnat_entity) == E_Function
6026                || Ekind (gnat_entity) == E_Procedure))
6027           || (gnu_old
6028               && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
6029               && Ekind (gnat_entity) == E_Subprogram_Type)))
6030     return;
6031
6032   /* If we have a non-dummy type old tree, we have nothing to do, except
6033      aborting if this is the public view of a private type whose full view was
6034      not delayed, as this node was never delayed as it should have been.  We
6035      let this happen for concurrent types and their Corresponding_Record_Type,
6036      however, because each might legitimately be elaborated before it's own
6037      freeze node, e.g. while processing the other.  */
6038   if (gnu_old
6039       && !(TREE_CODE (gnu_old) == TYPE_DECL
6040            && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
6041     {
6042       gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
6043                    && Present (Full_View (gnat_entity))
6044                    && No (Freeze_Node (Full_View (gnat_entity))))
6045                   || Is_Concurrent_Type (gnat_entity)
6046                   || (IN (Ekind (gnat_entity), Record_Kind)
6047                       && Is_Concurrent_Record_Type (gnat_entity)));
6048       return;
6049     }
6050
6051   /* Reset the saved tree, if any, and elaborate the object or type for real.
6052      If there is a full declaration, elaborate it and copy the type to
6053      GNAT_ENTITY.  Likewise if this is the record subtype corresponding to
6054      a class wide type or subtype.  */
6055   if (gnu_old)
6056     {
6057       save_gnu_tree (gnat_entity, NULL_TREE, false);
6058       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
6059           && Present (Full_View (gnat_entity))
6060           && present_gnu_tree (Full_View (gnat_entity)))
6061         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
6062       if (Present (Class_Wide_Type (gnat_entity))
6063           && Class_Wide_Type (gnat_entity) != gnat_entity)
6064         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
6065     }
6066
6067   if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
6068       && Present (Full_View (gnat_entity)))
6069     {
6070       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
6071
6072       /* Propagate back-annotations from full view to partial view.  */
6073       if (Unknown_Alignment (gnat_entity))
6074         Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
6075
6076       if (Unknown_Esize (gnat_entity))
6077         Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
6078
6079       if (Unknown_RM_Size (gnat_entity))
6080         Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
6081
6082       /* The above call may have defined this entity (the simplest example
6083          of this is when we have a private enumeral type since the bounds
6084          will have the public view.  */
6085       if (!present_gnu_tree (gnat_entity))
6086         save_gnu_tree (gnat_entity, gnu_new, false);
6087       if (Present (Class_Wide_Type (gnat_entity))
6088           && Class_Wide_Type (gnat_entity) != gnat_entity)
6089         save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
6090     }
6091   else
6092     gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
6093
6094   /* If we've made any pointers to the old version of this type, we
6095      have to update them.  */
6096   if (gnu_old)
6097     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
6098                        TREE_TYPE (gnu_new));
6099 }
6100 \f
6101 /* Process the list of inlined subprograms of GNAT_NODE, which is an
6102    N_Compilation_Unit.  */
6103
6104 static void
6105 process_inlined_subprograms (Node_Id gnat_node)
6106 {
6107   Entity_Id gnat_entity;
6108   Node_Id gnat_body;
6109
6110   /* If we can inline, generate Gimple for all the inlined subprograms.
6111      Define the entity first so we set DECL_EXTERNAL.  */
6112   if (optimize > 0)
6113     for (gnat_entity = First_Inlined_Subprogram (gnat_node);
6114          Present (gnat_entity);
6115          gnat_entity = Next_Inlined_Subprogram (gnat_entity))
6116       {
6117         gnat_body = Parent (Declaration_Node (gnat_entity));
6118
6119         if (Nkind (gnat_body) != N_Subprogram_Body)
6120           {
6121             /* ??? This really should always be Present.  */
6122             if (No (Corresponding_Body (gnat_body)))
6123               continue;
6124
6125             gnat_body
6126               = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
6127           }
6128
6129         if (Present (gnat_body))
6130           {
6131             gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
6132             add_stmt (gnat_to_gnu (gnat_body));
6133           }
6134       }
6135 }
6136 \f
6137 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
6138    We make two passes, one to elaborate anything other than bodies (but
6139    we declare a function if there was no spec).  The second pass
6140    elaborates the bodies.
6141
6142    GNAT_END_LIST gives the element in the list past the end.  Normally,
6143    this is Empty, but can be First_Real_Statement for a
6144    Handled_Sequence_Of_Statements.
6145
6146    We make a complete pass through both lists if PASS1P is true, then make
6147    the second pass over both lists if PASS2P is true.  The lists usually
6148    correspond to the public and private parts of a package.  */
6149
6150 static void
6151 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
6152                Node_Id gnat_end_list, bool pass1p, bool pass2p)
6153 {
6154   List_Id gnat_decl_array[2];
6155   Node_Id gnat_decl;
6156   int i;
6157
6158   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
6159
6160   if (pass1p)
6161     for (i = 0; i <= 1; i++)
6162       if (Present (gnat_decl_array[i]))
6163         for (gnat_decl = First (gnat_decl_array[i]);
6164              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6165           {
6166             /* For package specs, we recurse inside the declarations,
6167                thus taking the two pass approach inside the boundary.  */
6168             if (Nkind (gnat_decl) == N_Package_Declaration
6169                 && (Nkind (Specification (gnat_decl)
6170                            == N_Package_Specification)))
6171               process_decls (Visible_Declarations (Specification (gnat_decl)),
6172                              Private_Declarations (Specification (gnat_decl)),
6173                              Empty, true, false);
6174
6175             /* Similarly for any declarations in the actions of a
6176                freeze node.  */
6177             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6178               {
6179                 process_freeze_entity (gnat_decl);
6180                 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
6181               }
6182
6183             /* Package bodies with freeze nodes get their elaboration deferred
6184                until the freeze node, but the code must be placed in the right
6185                place, so record the code position now.  */
6186             else if (Nkind (gnat_decl) == N_Package_Body
6187                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
6188               record_code_position (gnat_decl);
6189
6190             else if (Nkind (gnat_decl) == N_Package_Body_Stub
6191                      && Present (Library_Unit (gnat_decl))
6192                      && Present (Freeze_Node
6193                                  (Corresponding_Spec
6194                                   (Proper_Body (Unit
6195                                                 (Library_Unit (gnat_decl)))))))
6196               record_code_position
6197                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
6198
6199             /* We defer most subprogram bodies to the second pass.  */
6200             else if (Nkind (gnat_decl) == N_Subprogram_Body)
6201               {
6202                 if (Acts_As_Spec (gnat_decl))
6203                   {
6204                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
6205
6206                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
6207                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6208                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6209                   }
6210               }
6211
6212             /* For bodies and stubs that act as their own specs, the entity
6213                itself must be elaborated in the first pass, because it may
6214                be used in other declarations.  */
6215             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
6216               {
6217                 Node_Id gnat_subprog_id
6218                   = Defining_Entity (Specification (gnat_decl));
6219
6220                     if (Ekind (gnat_subprog_id) != E_Subprogram_Body
6221                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
6222                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6223                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6224               }
6225
6226             /* Concurrent stubs stand for the corresponding subprogram bodies,
6227                which are deferred like other bodies.  */
6228             else if (Nkind (gnat_decl) == N_Task_Body_Stub
6229                      || Nkind (gnat_decl) == N_Protected_Body_Stub)
6230               ;
6231
6232             else
6233               add_stmt (gnat_to_gnu (gnat_decl));
6234           }
6235
6236   /* Here we elaborate everything we deferred above except for package bodies,
6237      which are elaborated at their freeze nodes.  Note that we must also
6238      go inside things (package specs and freeze nodes) the first pass did.  */
6239   if (pass2p)
6240     for (i = 0; i <= 1; i++)
6241       if (Present (gnat_decl_array[i]))
6242         for (gnat_decl = First (gnat_decl_array[i]);
6243              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6244           {
6245             if (Nkind (gnat_decl) == N_Subprogram_Body
6246                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
6247                 || Nkind (gnat_decl) == N_Task_Body_Stub
6248                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
6249               add_stmt (gnat_to_gnu (gnat_decl));
6250
6251             else if (Nkind (gnat_decl) == N_Package_Declaration
6252                      && (Nkind (Specification (gnat_decl)
6253                                 == N_Package_Specification)))
6254               process_decls (Visible_Declarations (Specification (gnat_decl)),
6255                              Private_Declarations (Specification (gnat_decl)),
6256                              Empty, false, true);
6257
6258             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6259               process_decls (Actions (gnat_decl), Empty, Empty, false, true);
6260           }
6261 }
6262 \f
6263 /* Make a unary operation of kind CODE using build_unary_op, but guard
6264    the operation by an overflow check.  CODE can be one of NEGATE_EXPR
6265    or ABS_EXPR.  GNU_TYPE is the type desired for the result.  Usually
6266    the operation is to be performed in that type.  GNAT_NODE is the gnat
6267    node conveying the source location for which the error should be
6268    signaled.  */
6269
6270 static tree
6271 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
6272                       Node_Id gnat_node)
6273 {
6274   gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
6275
6276   operand = protect_multiple_eval (operand);
6277
6278   return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
6279                                       operand, TYPE_MIN_VALUE (gnu_type)),
6280                      build_unary_op (code, gnu_type, operand),
6281                      CE_Overflow_Check_Failed, gnat_node);
6282 }
6283
6284 /* Make a binary operation of kind CODE using build_binary_op, but guard
6285    the operation by an overflow check.  CODE can be one of PLUS_EXPR,
6286    MINUS_EXPR or MULT_EXPR.  GNU_TYPE is the type desired for the result.
6287    Usually the operation is to be performed in that type.  GNAT_NODE is
6288    the GNAT node conveying the source location for which the error should
6289    be signaled.  */
6290
6291 static tree
6292 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
6293                        tree right, Node_Id gnat_node)
6294 {
6295   tree lhs = protect_multiple_eval (left);
6296   tree rhs = protect_multiple_eval (right);
6297   tree type_max = TYPE_MAX_VALUE (gnu_type);
6298   tree type_min = TYPE_MIN_VALUE (gnu_type);
6299   tree gnu_expr;
6300   tree tmp1, tmp2;
6301   tree zero = convert (gnu_type, integer_zero_node);
6302   tree rhs_lt_zero;
6303   tree check_pos;
6304   tree check_neg;
6305   tree check;
6306   int precision = TYPE_PRECISION (gnu_type);
6307
6308   gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */
6309
6310   /* Prefer a constant or known-positive rhs to simplify checks.  */
6311   if (!TREE_CONSTANT (rhs)
6312       && commutative_tree_code (code)
6313       && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs)
6314                                   && tree_expr_nonnegative_p (lhs))))
6315     {
6316       tree tmp = lhs;
6317       lhs = rhs;
6318       rhs = tmp;
6319     }
6320
6321   rhs_lt_zero = tree_expr_nonnegative_p (rhs)
6322                 ? integer_zero_node
6323                 : build_binary_op (LT_EXPR, integer_type_node, rhs, zero);
6324
6325   /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
6326
6327   /* Try a few strategies that may be cheaper than the general
6328      code at the end of the function, if the rhs is not known.
6329      The strategies are:
6330        - Call library function for 64-bit multiplication (complex)
6331        - Widen, if input arguments are sufficiently small
6332        - Determine overflow using wrapped result for addition/subtraction.  */
6333
6334   if (!TREE_CONSTANT (rhs))
6335     {
6336       /* Even for add/subtract double size to get another base type.  */
6337       int needed_precision = precision * 2;
6338
6339       if (code == MULT_EXPR && precision == 64)
6340         {
6341           tree int_64 = gnat_type_for_size (64, 0);
6342
6343           return convert (gnu_type, build_call_2_expr (mulv64_decl,
6344                                                        convert (int_64, lhs),
6345                                                        convert (int_64, rhs)));
6346         }
6347
6348       else if (needed_precision <= BITS_PER_WORD
6349                || (code == MULT_EXPR
6350                    && needed_precision <= LONG_LONG_TYPE_SIZE))
6351         {
6352           tree wide_type = gnat_type_for_size (needed_precision, 0);
6353
6354           tree wide_result = build_binary_op (code, wide_type,
6355                                               convert (wide_type, lhs),
6356                                               convert (wide_type, rhs));
6357
6358           tree check = build_binary_op
6359             (TRUTH_ORIF_EXPR, integer_type_node,
6360              build_binary_op (LT_EXPR, integer_type_node, wide_result,
6361                               convert (wide_type, type_min)),
6362              build_binary_op (GT_EXPR, integer_type_node, wide_result,
6363                               convert (wide_type, type_max)));
6364
6365           tree result = convert (gnu_type, wide_result);
6366
6367           return
6368             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
6369         }
6370
6371       else if (code == PLUS_EXPR || code == MINUS_EXPR)
6372         {
6373           tree unsigned_type = gnat_type_for_size (precision, 1);
6374           tree wrapped_expr = convert
6375             (gnu_type, build_binary_op (code, unsigned_type,
6376                                         convert (unsigned_type, lhs),
6377                                         convert (unsigned_type, rhs)));
6378
6379           tree result = convert
6380             (gnu_type, build_binary_op (code, gnu_type, lhs, rhs));
6381
6382           /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
6383              or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction.  */
6384           tree check = build_binary_op
6385             (TRUTH_XOR_EXPR, integer_type_node, rhs_lt_zero,
6386              build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
6387                               integer_type_node, wrapped_expr, lhs));
6388
6389           return
6390             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
6391         }
6392    }
6393
6394   switch (code)
6395     {
6396     case PLUS_EXPR:
6397       /* When rhs >= 0, overflow when lhs > type_max - rhs.  */
6398       check_pos = build_binary_op (GT_EXPR, integer_type_node, lhs,
6399                                    build_binary_op (MINUS_EXPR, gnu_type,
6400                                                     type_max, rhs)),
6401
6402       /* When rhs < 0, overflow when lhs < type_min - rhs.  */
6403       check_neg = build_binary_op (LT_EXPR, integer_type_node, lhs,
6404                                    build_binary_op (MINUS_EXPR, gnu_type,
6405                                                     type_min, rhs));
6406       break;
6407
6408     case MINUS_EXPR:
6409       /* When rhs >= 0, overflow when lhs < type_min + rhs.  */
6410       check_pos = build_binary_op (LT_EXPR, integer_type_node, lhs,
6411                                    build_binary_op (PLUS_EXPR, gnu_type,
6412                                                     type_min, rhs)),
6413
6414       /* When rhs < 0, overflow when lhs > type_max + rhs.  */
6415       check_neg = build_binary_op (GT_EXPR, integer_type_node, lhs,
6416                                    build_binary_op (PLUS_EXPR, gnu_type,
6417                                                     type_max, rhs));
6418       break;
6419
6420     case MULT_EXPR:
6421       /* The check here is designed to be efficient if the rhs is constant,
6422          but it will work for any rhs by using integer division.
6423          Four different check expressions determine wether X * C overflows,
6424          depending on C.
6425            C ==  0  =>  false
6426            C  >  0  =>  X > type_max / C || X < type_min / C
6427            C == -1  =>  X == type_min
6428            C  < -1  =>  X > type_min / C || X < type_max / C */
6429
6430       tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
6431       tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
6432
6433       check_pos = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6434                     build_binary_op (NE_EXPR, integer_type_node, zero, rhs),
6435                     build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6436                       build_binary_op (GT_EXPR, integer_type_node, lhs, tmp1),
6437                       build_binary_op (LT_EXPR, integer_type_node, lhs, tmp2)));
6438
6439       check_neg = fold_build3 (COND_EXPR, integer_type_node,
6440                     build_binary_op (EQ_EXPR, integer_type_node, rhs,
6441                                      build_int_cst (gnu_type, -1)),
6442                     build_binary_op (EQ_EXPR, integer_type_node, lhs, type_min),
6443                     build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6444                       build_binary_op (GT_EXPR, integer_type_node, lhs, tmp2),
6445                       build_binary_op (LT_EXPR, integer_type_node, lhs, tmp1)));
6446       break;
6447
6448     default:
6449       gcc_unreachable();
6450     }
6451
6452   gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
6453
6454   /* If we can fold the expression to a constant, just return it.
6455      The caller will deal with overflow, no need to generate a check.  */
6456   if (TREE_CONSTANT (gnu_expr))
6457     return gnu_expr;
6458
6459   check = fold_build3 (COND_EXPR, integer_type_node,
6460                        rhs_lt_zero,  check_neg, check_pos);
6461
6462   return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
6463 }
6464
6465 /* Emit code for a range check.  GNU_EXPR is the expression to be checked,
6466    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
6467    which we have to check.  GNAT_NODE is the GNAT node conveying the source
6468    location for which the error should be signaled.  */
6469
6470 static tree
6471 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
6472 {
6473   tree gnu_range_type = get_unpadded_type (gnat_range_type);
6474   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
6475   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
6476   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
6477
6478   /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
6479      This can for example happen when translating 'Val or 'Value.  */
6480   if (gnu_compare_type == gnu_range_type)
6481     return gnu_expr;
6482
6483   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
6484      we can't do anything since we might be truncating the bounds.  No
6485      check is needed in this case.  */
6486   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
6487       && (TYPE_PRECISION (gnu_compare_type)
6488           < TYPE_PRECISION (get_base_type (gnu_range_type))))
6489     return gnu_expr;
6490
6491   /* Checked expressions must be evaluated only once.  */
6492   gnu_expr = protect_multiple_eval (gnu_expr);
6493
6494   /* There's no good type to use here, so we might as well use
6495      integer_type_node. Note that the form of the check is
6496         (not (expr >= lo)) or (not (expr <= hi))
6497      the reason for this slightly convoluted form is that NaNs
6498      are not considered to be in range in the float case.  */
6499   return emit_check
6500     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6501                       invert_truthvalue
6502                       (build_binary_op (GE_EXPR, integer_type_node,
6503                                        convert (gnu_compare_type, gnu_expr),
6504                                        convert (gnu_compare_type, gnu_low))),
6505                       invert_truthvalue
6506                       (build_binary_op (LE_EXPR, integer_type_node,
6507                                         convert (gnu_compare_type, gnu_expr),
6508                                         convert (gnu_compare_type,
6509                                                  gnu_high)))),
6510      gnu_expr, CE_Range_Check_Failed, gnat_node);
6511 }
6512 \f
6513 /* Emit code for an index check.  GNU_ARRAY_OBJECT is the array object which
6514    we are about to index, GNU_EXPR is the index expression to be checked,
6515    GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
6516    has to be checked.  Note that for index checking we cannot simply use the
6517    emit_range_check function (although very similar code needs to be generated
6518    in both cases) since for index checking the array type against which we are
6519    checking the indices may be unconstrained and consequently we need to get
6520    the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
6521    The place where we need to do that is in subprograms having unconstrained
6522    array formal parameters.  GNAT_NODE is the GNAT node conveying the source
6523    location for which the error should be signaled.  */
6524
6525 static tree
6526 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
6527                   tree gnu_high, Node_Id gnat_node)
6528 {
6529   tree gnu_expr_check;
6530
6531   /* Checked expressions must be evaluated only once.  */
6532   gnu_expr = protect_multiple_eval (gnu_expr);
6533
6534   /* Must do this computation in the base type in case the expression's
6535      type is an unsigned subtypes.  */
6536   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
6537
6538   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
6539      the object we are handling.  */
6540   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
6541   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
6542
6543   /* There's no good type to use here, so we might as well use
6544      integer_type_node.   */
6545   return emit_check
6546     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6547                       build_binary_op (LT_EXPR, integer_type_node,
6548                                        gnu_expr_check,
6549                                        convert (TREE_TYPE (gnu_expr_check),
6550                                                 gnu_low)),
6551                       build_binary_op (GT_EXPR, integer_type_node,
6552                                        gnu_expr_check,
6553                                        convert (TREE_TYPE (gnu_expr_check),
6554                                                 gnu_high))),
6555      gnu_expr, CE_Index_Check_Failed, gnat_node);
6556 }
6557 \f
6558 /* GNU_COND contains the condition corresponding to an access, discriminant or
6559    range check of value GNU_EXPR.  Build a COND_EXPR that returns GNU_EXPR if
6560    GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
6561    REASON is the code that says why the exception was raised.  GNAT_NODE is
6562    the GNAT node conveying the source location for which the error should be
6563    signaled.  */
6564
6565 static tree
6566 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
6567 {
6568   tree gnu_call
6569     = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
6570   tree gnu_result
6571     = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
6572                    build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
6573                            convert (TREE_TYPE (gnu_expr), integer_zero_node)),
6574                    gnu_expr);
6575
6576   /* GNU_RESULT has side effects if and only if GNU_EXPR has:
6577      we don't need to evaluate it just for the check.  */
6578   TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
6579
6580   /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
6581      we will repeatedly do the test and, at compile time, we will repeatedly
6582      visit it during unsharing, which leads to an exponential explosion.  */
6583   return save_expr (gnu_result);
6584 }
6585 \f
6586 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
6587    checks if OVERFLOW_P is true and range checks if RANGE_P is true.
6588    GNAT_TYPE is known to be an integral type.  If TRUNCATE_P true, do a
6589    float to integer conversion with truncation; otherwise round.
6590    GNAT_NODE is the GNAT node conveying the source location for which the
6591    error should be signaled.  */
6592
6593 static tree
6594 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
6595                     bool rangep, bool truncatep, Node_Id gnat_node)
6596 {
6597   tree gnu_type = get_unpadded_type (gnat_type);
6598   tree gnu_in_type = TREE_TYPE (gnu_expr);
6599   tree gnu_in_basetype = get_base_type (gnu_in_type);
6600   tree gnu_base_type = get_base_type (gnu_type);
6601   tree gnu_result = gnu_expr;
6602
6603   /* If we are not doing any checks, the output is an integral type, and
6604      the input is not a floating type, just do the conversion.  This
6605      shortcut is required to avoid problems with packed array types
6606      and simplifies code in all cases anyway.   */
6607   if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
6608       && !FLOAT_TYPE_P (gnu_in_type))
6609     return convert (gnu_type, gnu_expr);
6610
6611   /* First convert the expression to its base type.  This
6612      will never generate code, but makes the tests below much simpler.
6613      But don't do this if converting from an integer type to an unconstrained
6614      array type since then we need to get the bounds from the original
6615      (unpacked) type.  */
6616   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
6617     gnu_result = convert (gnu_in_basetype, gnu_result);
6618
6619   /* If overflow checks are requested,  we need to be sure the result will
6620      fit in the output base type.  But don't do this if the input
6621      is integer and the output floating-point.  */
6622   if (overflowp
6623       && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
6624     {
6625       /* Ensure GNU_EXPR only gets evaluated once.  */
6626       tree gnu_input = protect_multiple_eval (gnu_result);
6627       tree gnu_cond = integer_zero_node;
6628       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
6629       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
6630       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
6631       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
6632
6633       /* Convert the lower bounds to signed types, so we're sure we're
6634          comparing them properly.  Likewise, convert the upper bounds
6635          to unsigned types.  */
6636       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
6637         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
6638
6639       if (INTEGRAL_TYPE_P (gnu_in_basetype)
6640           && !TYPE_UNSIGNED (gnu_in_basetype))
6641         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
6642
6643       if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
6644         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
6645
6646       if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
6647         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
6648
6649       /* Check each bound separately and only if the result bound
6650          is tighter than the bound on the input type.  Note that all the
6651          types are base types, so the bounds must be constant. Also,
6652          the comparison is done in the base type of the input, which
6653          always has the proper signedness.  First check for input
6654          integer (which means output integer), output float (which means
6655          both float), or mixed, in which case we always compare.
6656          Note that we have to do the comparison which would *fail* in the
6657          case of an error since if it's an FP comparison and one of the
6658          values is a NaN or Inf, the comparison will fail.  */
6659       if (INTEGRAL_TYPE_P (gnu_in_basetype)
6660           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
6661           : (FLOAT_TYPE_P (gnu_base_type)
6662              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
6663                                  TREE_REAL_CST (gnu_out_lb))
6664              : 1))
6665         gnu_cond
6666           = invert_truthvalue
6667             (build_binary_op (GE_EXPR, integer_type_node,
6668                               gnu_input, convert (gnu_in_basetype,
6669                                                   gnu_out_lb)));
6670
6671       if (INTEGRAL_TYPE_P (gnu_in_basetype)
6672           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
6673           : (FLOAT_TYPE_P (gnu_base_type)
6674              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
6675                                  TREE_REAL_CST (gnu_in_lb))
6676              : 1))
6677         gnu_cond
6678           = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
6679                              invert_truthvalue
6680                              (build_binary_op (LE_EXPR, integer_type_node,
6681                                                gnu_input,
6682                                                convert (gnu_in_basetype,
6683                                                         gnu_out_ub))));
6684
6685       if (!integer_zerop (gnu_cond))
6686         gnu_result = emit_check (gnu_cond, gnu_input,
6687                                  CE_Overflow_Check_Failed, gnat_node);
6688     }
6689
6690   /* Now convert to the result base type.  If this is a non-truncating
6691      float-to-integer conversion, round.  */
6692   if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
6693       && !truncatep)
6694     {
6695       REAL_VALUE_TYPE half_minus_pred_half, pred_half;
6696       tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type;
6697       tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
6698       const struct real_format *fmt;
6699
6700       /* The following calculations depend on proper rounding to even
6701          of each arithmetic operation. In order to prevent excess
6702          precision from spoiling this property, use the widest hardware
6703          floating-point type if FP_ARITH_MAY_WIDEN is true.  */
6704       calc_type
6705         = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
6706
6707       /* FIXME: Should not have padding in the first place.  */
6708       if (TREE_CODE (calc_type) == RECORD_TYPE
6709           && TYPE_IS_PADDING_P (calc_type))
6710         calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
6711
6712       /* Compute the exact value calc_type'Pred (0.5) at compile time.  */
6713       fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
6714       real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
6715       REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
6716                        half_minus_pred_half);
6717       gnu_pred_half = build_real (calc_type, pred_half);
6718
6719       /* If the input is strictly negative, subtract this value
6720          and otherwise add it from the input. For 0.5, the result
6721          is exactly between 1.0 and the machine number preceding 1.0
6722          (for calc_type). Since the last bit of 1.0 is even, this 0.5
6723          will round to 1.0, while all other number with an absolute
6724          value less than 0.5 round to 0.0. For larger numbers exactly
6725          halfway between integers, rounding will always be correct as
6726          the true mathematical result will be closer to the higher
6727          integer compared to the lower one. So, this constant works
6728          for all floating-point numbers.
6729
6730          The reason to use the same constant with subtract/add instead
6731          of a positive and negative constant is to allow the comparison
6732          to be scheduled in parallel with retrieval of the constant and
6733          conversion of the input to the calc_type (if necessary).  */
6734
6735       gnu_zero = convert (gnu_in_basetype, integer_zero_node);
6736       gnu_saved_result = save_expr (gnu_result);
6737       gnu_conv = convert (calc_type, gnu_saved_result);
6738       gnu_comp = build2 (GE_EXPR, integer_type_node,
6739                          gnu_saved_result, gnu_zero);
6740       gnu_add_pred_half
6741         = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
6742       gnu_subtract_pred_half
6743         = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
6744       gnu_result = build3 (COND_EXPR, calc_type, gnu_comp,
6745                            gnu_add_pred_half, gnu_subtract_pred_half);
6746     }
6747
6748   if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
6749       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
6750       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
6751     gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
6752   else
6753     gnu_result = convert (gnu_base_type, gnu_result);
6754
6755   /* Finally, do the range check if requested.  Note that if the
6756      result type is a modular type, the range check is actually
6757      an overflow check.  */
6758
6759   if (rangep
6760       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
6761           && TYPE_MODULAR_P (gnu_base_type) && overflowp))
6762     gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
6763
6764   return convert (gnu_type, gnu_result);
6765 }
6766 \f
6767 /* Return true if TYPE is a smaller packable version of RECORD_TYPE.  */
6768
6769 static bool
6770 smaller_packable_type_p (tree type, tree record_type)
6771 {
6772   tree size, rsize;
6773
6774   /* We're not interested in variants here.  */
6775   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (record_type))
6776     return false;
6777
6778   /* Like a variant, a packable version keeps the original TYPE_NAME.  */
6779   if (TYPE_NAME (type) != TYPE_NAME (record_type))
6780     return false;
6781
6782   size = TYPE_SIZE (type);
6783   rsize = TYPE_SIZE (record_type);
6784
6785   if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (rsize) == INTEGER_CST))
6786     return false;
6787
6788   return tree_int_cst_lt (size, rsize) != 0;
6789 }
6790
6791 /* Return true if GNU_EXPR can be directly addressed.  This is the case
6792    unless it is an expression involving computation or if it involves a
6793    reference to a bitfield or to an object not sufficiently aligned for
6794    its type.  If GNU_TYPE is non-null, return true only if GNU_EXPR can
6795    be directly addressed as an object of this type.
6796
6797    *** Notes on addressability issues in the Ada compiler ***
6798
6799    This predicate is necessary in order to bridge the gap between Gigi
6800    and the middle-end about addressability of GENERIC trees.  A tree
6801    is said to be addressable if it can be directly addressed, i.e. if
6802    its address can be taken, is a multiple of the type's alignment on
6803    strict-alignment architectures and returns the first storage unit
6804    assigned to the object represented by the tree.
6805
6806    In the C family of languages, everything is in practice addressable
6807    at the language level, except for bit-fields.  This means that these
6808    compilers will take the address of any tree that doesn't represent
6809    a bit-field reference and expect the result to be the first storage
6810    unit assigned to the object.  Even in cases where this will result
6811    in unaligned accesses at run time, nothing is supposed to be done
6812    and the program is considered as erroneous instead (see PR c/18287).
6813
6814    The implicit assumptions made in the middle-end are in keeping with
6815    the C viewpoint described above:
6816      - the address of a bit-field reference is supposed to be never
6817        taken; the compiler (generally) will stop on such a construct,
6818      - any other tree is addressable if it is formally addressable,
6819        i.e. if it is formally allowed to be the operand of ADDR_EXPR.
6820
6821    In Ada, the viewpoint is the opposite one: nothing is addressable
6822    at the language level unless explicitly declared so.  This means
6823    that the compiler will both make sure that the trees representing
6824    references to addressable ("aliased" in Ada parlance) objects are
6825    addressable and make no real attempts at ensuring that the trees
6826    representing references to non-addressable objects are addressable.
6827
6828    In the first case, Ada is effectively equivalent to C and handing
6829    down the direct result of applying ADDR_EXPR to these trees to the
6830    middle-end works flawlessly.  In the second case, Ada cannot afford
6831    to consider the program as erroneous if the address of trees that
6832    are not addressable is requested for technical reasons, unlike C;
6833    as a consequence, the Ada compiler must arrange for either making
6834    sure that this address is not requested in the middle-end or for
6835    compensating by inserting temporaries if it is requested in Gigi.
6836
6837    The first goal can be achieved because the middle-end should not
6838    request the address of non-addressable trees on its own; the only
6839    exception is for the invocation of low-level block operations like
6840    memcpy, for which the addressability requirements are lower since
6841    the type's alignment can be disregarded.  In practice, this means
6842    that Gigi must make sure that such operations cannot be applied to
6843    non-BLKmode bit-fields.
6844
6845    The second goal is achieved by means of the addressable_p predicate
6846    and by inserting SAVE_EXPRs around trees deemed non-addressable.
6847    They will be turned during gimplification into proper temporaries
6848    whose address will be used in lieu of that of the original tree.  */
6849
6850 static bool
6851 addressable_p (tree gnu_expr, tree gnu_type)
6852 {
6853   /* The size of the real type of the object must not be smaller than
6854      that of the expected type, otherwise an indirect access in the
6855      latter type would be larger than the object.  Only records need
6856      to be considered in practice.  */
6857   if (gnu_type
6858       && TREE_CODE (gnu_type) == RECORD_TYPE
6859       && smaller_packable_type_p (TREE_TYPE (gnu_expr), gnu_type))
6860     return false;
6861
6862   switch (TREE_CODE (gnu_expr))
6863     {
6864     case VAR_DECL:
6865     case PARM_DECL:
6866     case FUNCTION_DECL:
6867     case RESULT_DECL:
6868       /* All DECLs are addressable: if they are in a register, we can force
6869          them to memory.  */
6870       return true;
6871
6872     case UNCONSTRAINED_ARRAY_REF:
6873     case INDIRECT_REF:
6874     case CONSTRUCTOR:
6875     case STRING_CST:
6876     case INTEGER_CST:
6877     case NULL_EXPR:
6878     case SAVE_EXPR:
6879     case CALL_EXPR:
6880       return true;
6881
6882     case COND_EXPR:
6883       /* We accept &COND_EXPR as soon as both operands are addressable and
6884          expect the outcome to be the address of the selected operand.  */
6885       return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
6886               && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
6887
6888     case COMPONENT_REF:
6889       return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
6890                 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
6891                    the field is sufficiently aligned, in case it is subject
6892                    to a pragma Component_Alignment.  But we don't need to
6893                    check the alignment of the containing record, as it is
6894                    guaranteed to be not smaller than that of its most
6895                    aligned field that is not a bit-field.  */
6896                 && (!STRICT_ALIGNMENT
6897                     || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
6898                        >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
6899                /* The field of a padding record is always addressable.  */
6900                || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
6901               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
6902
6903     case ARRAY_REF:  case ARRAY_RANGE_REF:
6904     case REALPART_EXPR:  case IMAGPART_EXPR:
6905     case NOP_EXPR:
6906       return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
6907
6908     case CONVERT_EXPR:
6909       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
6910               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
6911
6912     case VIEW_CONVERT_EXPR:
6913       {
6914         /* This is addressable if we can avoid a copy.  */
6915         tree type = TREE_TYPE (gnu_expr);
6916         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
6917         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
6918                   && (!STRICT_ALIGNMENT
6919                       || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
6920                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
6921                  || ((TYPE_MODE (type) == BLKmode
6922                       || TYPE_MODE (inner_type) == BLKmode)
6923                      && (!STRICT_ALIGNMENT
6924                          || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
6925                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
6926                          || TYPE_ALIGN_OK (type)
6927                          || TYPE_ALIGN_OK (inner_type))))
6928                 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
6929       }
6930
6931     default:
6932       return false;
6933     }
6934 }
6935 \f
6936 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
6937    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
6938    make a GCC type for GNAT_ENTITY and set up the correspondence.  */
6939
6940 void
6941 process_type (Entity_Id gnat_entity)
6942 {
6943   tree gnu_old
6944     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
6945   tree gnu_new;
6946
6947   /* If we are to delay elaboration of this type, just do any
6948      elaborations needed for expressions within the declaration and
6949      make a dummy type entry for this node and its Full_View (if
6950      any) in case something points to it.  Don't do this if it
6951      has already been done (the only way that can happen is if
6952      the private completion is also delayed).  */
6953   if (Present (Freeze_Node (gnat_entity))
6954       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
6955           && Present (Full_View (gnat_entity))
6956           && Freeze_Node (Full_View (gnat_entity))
6957           && !present_gnu_tree (Full_View (gnat_entity))))
6958     {
6959       elaborate_entity (gnat_entity);
6960
6961       if (!gnu_old)
6962         {
6963           tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
6964           save_gnu_tree (gnat_entity, gnu_decl, false);
6965           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
6966               && Present (Full_View (gnat_entity)))
6967             save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
6968         }
6969
6970       return;
6971     }
6972
6973   /* If we saved away a dummy type for this node it means that this
6974      made the type that corresponds to the full type of an incomplete
6975      type.  Clear that type for now and then update the type in the
6976      pointers.  */
6977   if (gnu_old)
6978     {
6979       gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
6980                   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
6981
6982       save_gnu_tree (gnat_entity, NULL_TREE, false);
6983     }
6984
6985   /* Now fully elaborate the type.  */
6986   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
6987   gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
6988
6989   /* If we have an old type and we've made pointers to this type,
6990      update those pointers.  */
6991   if (gnu_old)
6992     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
6993                        TREE_TYPE (gnu_new));
6994
6995   /* If this is a record type corresponding to a task or protected type
6996      that is a completion of an incomplete type, perform a similar update
6997      on the type.  ??? Including protected types here is a guess.  */
6998   if (IN (Ekind (gnat_entity), Record_Kind)
6999       && Is_Concurrent_Record_Type (gnat_entity)
7000       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
7001     {
7002       tree gnu_task_old
7003         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
7004
7005       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7006                      NULL_TREE, false);
7007       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7008                      gnu_new, false);
7009
7010       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
7011                          TREE_TYPE (gnu_new));
7012     }
7013 }
7014 \f
7015 /* GNAT_ENTITY is the type of the resulting constructors,
7016    GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
7017    and GNU_TYPE is the GCC type of the corresponding record.
7018
7019    Return a CONSTRUCTOR to build the record.  */
7020
7021 static tree
7022 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
7023 {
7024   tree gnu_list, gnu_result;
7025
7026   /* We test for GNU_FIELD being empty in the case where a variant
7027      was the last thing since we don't take things off GNAT_ASSOC in
7028      that case.  We check GNAT_ASSOC in case we have a variant, but it
7029      has no fields.  */
7030
7031   for (gnu_list = NULL_TREE; Present (gnat_assoc);
7032        gnat_assoc = Next (gnat_assoc))
7033     {
7034       Node_Id gnat_field = First (Choices (gnat_assoc));
7035       tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
7036       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
7037
7038       /* The expander is supposed to put a single component selector name
7039          in every record component association.  */
7040       gcc_assert (No (Next (gnat_field)));
7041
7042       /* Ignore fields that have Corresponding_Discriminants since we'll
7043          be setting that field in the parent.  */
7044       if (Present (Corresponding_Discriminant (Entity (gnat_field)))
7045           && Is_Tagged_Type (Scope (Entity (gnat_field))))
7046         continue;
7047
7048       /* Also ignore discriminants of Unchecked_Unions.  */
7049       else if (Is_Unchecked_Union (gnat_entity)
7050                && Ekind (Entity (gnat_field)) == E_Discriminant)
7051         continue;
7052
7053       /* Before assigning a value in an aggregate make sure range checks
7054          are done if required.  Then convert to the type of the field.  */
7055       if (Do_Range_Check (Expression (gnat_assoc)))
7056         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
7057
7058       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
7059
7060       /* Add the field and expression to the list.  */
7061       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
7062     }
7063
7064   gnu_result = extract_values (gnu_list, gnu_type);
7065
7066 #ifdef ENABLE_CHECKING
7067   {
7068     tree gnu_field;
7069
7070     /* Verify every entry in GNU_LIST was used.  */
7071     for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
7072       gcc_assert (TREE_ADDRESSABLE (gnu_field));
7073   }
7074 #endif
7075
7076   return gnu_result;
7077 }
7078
7079 /* Build a possibly nested constructor for array aggregates.  GNAT_EXPR is
7080    the first element of an array aggregate.  It may itself be an aggregate.
7081    GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
7082    GNAT_COMPONENT_TYPE is the type of the array component; it is needed
7083    for range checking.  */
7084
7085 static tree
7086 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
7087                     Entity_Id gnat_component_type)
7088 {
7089   tree gnu_expr_list = NULL_TREE;
7090   tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
7091   tree gnu_expr;
7092
7093   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
7094     {
7095       /* If the expression is itself an array aggregate then first build the
7096          innermost constructor if it is part of our array (multi-dimensional
7097          case).  */
7098       if (Nkind (gnat_expr) == N_Aggregate
7099           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
7100           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
7101         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
7102                                        TREE_TYPE (gnu_array_type),
7103                                        gnat_component_type);
7104       else
7105         {
7106           gnu_expr = gnat_to_gnu (gnat_expr);
7107
7108           /* Before assigning the element to the array, make sure it is
7109              in range.  */
7110           if (Do_Range_Check (gnat_expr))
7111             gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
7112         }
7113
7114       gnu_expr_list
7115         = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr),
7116                      gnu_expr_list);
7117
7118       gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
7119     }
7120
7121   return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
7122 }
7123 \f
7124 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
7125    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
7126    of the associations that are from RECORD_TYPE.  If we see an internal
7127    record, make a recursive call to fill it in as well.  */
7128
7129 static tree
7130 extract_values (tree values, tree record_type)
7131 {
7132   tree result = NULL_TREE;
7133   tree field, tem;
7134
7135   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
7136     {
7137       tree value = 0;
7138
7139       /* _Parent is an internal field, but may have values in the aggregate,
7140          so check for values first.  */
7141       if ((tem = purpose_member (field, values)))
7142         {
7143           value = TREE_VALUE (tem);
7144           TREE_ADDRESSABLE (tem) = 1;
7145         }
7146
7147       else if (DECL_INTERNAL_P (field))
7148         {
7149           value = extract_values (values, TREE_TYPE (field));
7150           if (TREE_CODE (value) == CONSTRUCTOR
7151               && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
7152             value = 0;
7153         }
7154       else
7155         /* If we have a record subtype, the names will match, but not the
7156            actual FIELD_DECLs.  */
7157         for (tem = values; tem; tem = TREE_CHAIN (tem))
7158           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
7159             {
7160               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
7161               TREE_ADDRESSABLE (tem) = 1;
7162             }
7163
7164       if (!value)
7165         continue;
7166
7167       result = tree_cons (field, value, result);
7168     }
7169
7170   return gnat_build_constructor (record_type, nreverse (result));
7171 }
7172 \f
7173 /* EXP is to be treated as an array or record.  Handle the cases when it is
7174    an access object and perform the required dereferences.  */
7175
7176 static tree
7177 maybe_implicit_deref (tree exp)
7178 {
7179   /* If the type is a pointer, dereference it.  */
7180
7181   if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
7182     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
7183
7184   /* If we got a padded type, remove it too.  */
7185   if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
7186       && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
7187     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
7188
7189   return exp;
7190 }
7191 \f
7192 /* Protect EXP from multiple evaluation.  This may make a SAVE_EXPR.  */
7193
7194 tree
7195 protect_multiple_eval (tree exp)
7196 {
7197   tree type = TREE_TYPE (exp);
7198
7199   /* If this has no side effects, we don't need to do anything.  */
7200   if (!TREE_SIDE_EFFECTS (exp))
7201     return exp;
7202
7203   /* If it is a conversion, protect what's inside the conversion.
7204      Similarly, if we're indirectly referencing something, we only
7205      actually need to protect the address since the data itself can't
7206      change in these situations.  */
7207   else if (TREE_CODE (exp) == NON_LVALUE_EXPR
7208            || CONVERT_EXPR_P (exp)
7209            || TREE_CODE (exp) == VIEW_CONVERT_EXPR
7210            || TREE_CODE (exp) == INDIRECT_REF
7211            || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
7212     return build1 (TREE_CODE (exp), type,
7213                    protect_multiple_eval (TREE_OPERAND (exp, 0)));
7214
7215   /* If EXP is a fat pointer or something that can be placed into a register,
7216      just make a SAVE_EXPR.  */
7217   if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
7218     return save_expr (exp);
7219
7220   /* Otherwise, dereference, protect the address, and re-reference.  */
7221   else
7222     return
7223       build_unary_op (INDIRECT_REF, type,
7224                       save_expr (build_unary_op (ADDR_EXPR,
7225                                                  build_reference_type (type),
7226                                                  exp)));
7227 }
7228 \f
7229 /* This is equivalent to stabilize_reference in tree.c, but we know how to
7230    handle our own nodes and we take extra arguments.  FORCE says whether to
7231    force evaluation of everything.  We set SUCCESS to true unless we walk
7232    through something we don't know how to stabilize.  */
7233
7234 tree
7235 maybe_stabilize_reference (tree ref, bool force, bool *success)
7236 {
7237   tree type = TREE_TYPE (ref);
7238   enum tree_code code = TREE_CODE (ref);
7239   tree result;
7240
7241   /* Assume we'll success unless proven otherwise.  */
7242   *success = true;
7243
7244   switch (code)
7245     {
7246     case CONST_DECL:
7247     case VAR_DECL:
7248     case PARM_DECL:
7249     case RESULT_DECL:
7250       /* No action is needed in this case.  */
7251       return ref;
7252
7253     case ADDR_EXPR:
7254     CASE_CONVERT:
7255     case FLOAT_EXPR:
7256     case FIX_TRUNC_EXPR:
7257     case VIEW_CONVERT_EXPR:
7258       result
7259         = build1 (code, type,
7260                   maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
7261                                              success));
7262       break;
7263
7264     case INDIRECT_REF:
7265     case UNCONSTRAINED_ARRAY_REF:
7266       result = build1 (code, type,
7267                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
7268                                                    force));
7269       break;
7270
7271     case COMPONENT_REF:
7272      result = build3 (COMPONENT_REF, type,
7273                       maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
7274                                                  success),
7275                       TREE_OPERAND (ref, 1), NULL_TREE);
7276       break;
7277
7278     case BIT_FIELD_REF:
7279       result = build3 (BIT_FIELD_REF, type,
7280                        maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
7281                                                   success),
7282                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
7283                                                    force),
7284                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
7285                                                    force));
7286       break;
7287
7288     case ARRAY_REF:
7289     case ARRAY_RANGE_REF:
7290       result = build4 (code, type,
7291                        maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
7292                                                   success),
7293                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
7294                                                    force),
7295                        NULL_TREE, NULL_TREE);
7296       break;
7297
7298     case COMPOUND_EXPR:
7299       result = gnat_stabilize_reference_1 (ref, force);
7300       break;
7301
7302     case CALL_EXPR:
7303       /* This generates better code than the scheme in protect_multiple_eval
7304          because large objects will be returned via invisible reference in
7305          most ABIs so the temporary will directly be filled by the callee.  */
7306       result = gnat_stabilize_reference_1 (ref, force);
7307       break;
7308
7309     case CONSTRUCTOR:
7310       /* Constructors with 1 element are used extensively to formally
7311          convert objects to special wrapping types.  */
7312       if (TREE_CODE (type) == RECORD_TYPE
7313           && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1)
7314         {
7315           tree index
7316             = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index;
7317           tree value
7318             = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value;
7319           result
7320             = build_constructor_single (type, index,
7321                                         gnat_stabilize_reference_1 (value,
7322                                                                     force));
7323         }
7324       else
7325         {
7326           *success = false;
7327           return ref;
7328         }
7329       break;
7330
7331     case ERROR_MARK:
7332       ref = error_mark_node;
7333
7334       /* ...  fall through to failure ... */
7335
7336       /* If arg isn't a kind of lvalue we recognize, make no change.
7337          Caller should recognize the error for an invalid lvalue.  */
7338     default:
7339       *success = false;
7340       return ref;
7341     }
7342
7343   TREE_READONLY (result) = TREE_READONLY (ref);
7344
7345   /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
7346      expression may not be sustained across some paths, such as the way via
7347      build1 for INDIRECT_REF.  We re-populate those flags here for the general
7348      case, which is consistent with the GCC version of this routine.
7349
7350      Special care should be taken regarding TREE_SIDE_EFFECTS, because some
7351      paths introduce side effects where there was none initially (e.g. calls
7352      to save_expr), and we also want to keep track of that.  */
7353
7354   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
7355   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
7356
7357   return result;
7358 }
7359
7360 /* Wrapper around maybe_stabilize_reference, for common uses without
7361    lvalue restrictions and without need to examine the success
7362    indication.  */
7363
7364 static tree
7365 gnat_stabilize_reference (tree ref, bool force)
7366 {
7367   bool dummy;
7368   return maybe_stabilize_reference (ref, force, &dummy);
7369 }
7370
7371 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
7372    arg to force a SAVE_EXPR for everything.  */
7373
7374 static tree
7375 gnat_stabilize_reference_1 (tree e, bool force)
7376 {
7377   enum tree_code code = TREE_CODE (e);
7378   tree type = TREE_TYPE (e);
7379   tree result;
7380
7381   /* We cannot ignore const expressions because it might be a reference
7382      to a const array but whose index contains side-effects.  But we can
7383      ignore things that are actual constant or that already have been
7384      handled by this function.  */
7385
7386   if (TREE_CONSTANT (e) || code == SAVE_EXPR)
7387     return e;
7388
7389   switch (TREE_CODE_CLASS (code))
7390     {
7391     case tcc_exceptional:
7392     case tcc_type:
7393     case tcc_declaration:
7394     case tcc_comparison:
7395     case tcc_statement:
7396     case tcc_expression:
7397     case tcc_reference:
7398     case tcc_vl_exp:
7399       /* If this is a COMPONENT_REF of a fat pointer, save the entire
7400          fat pointer.  This may be more efficient, but will also allow
7401          us to more easily find the match for the PLACEHOLDER_EXPR.  */
7402       if (code == COMPONENT_REF
7403           && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
7404         result = build3 (COMPONENT_REF, type,
7405                          gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
7406                                                      force),
7407                          TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
7408       else if (TREE_SIDE_EFFECTS (e) || force)
7409         return save_expr (e);
7410       else
7411         return e;
7412       break;
7413
7414     case tcc_constant:
7415       /* Constants need no processing.  In fact, we should never reach
7416          here.  */
7417       return e;
7418
7419     case tcc_binary:
7420       /* Recursively stabilize each operand.  */
7421       result = build2 (code, type,
7422                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
7423                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
7424                                                    force));
7425       break;
7426
7427     case tcc_unary:
7428       /* Recursively stabilize each operand.  */
7429       result = build1 (code, type,
7430                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
7431                                                    force));
7432       break;
7433
7434     default:
7435       gcc_unreachable ();
7436     }
7437
7438   TREE_READONLY (result) = TREE_READONLY (e);
7439
7440   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
7441   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
7442   return result;
7443 }
7444 \f
7445 /* Convert SLOC into LOCUS.  Return true if SLOC corresponds to a source code
7446    location and false if it doesn't.  In the former case, set the Gigi global
7447    variable REF_FILENAME to the simple debug file name as given by sinput.  */
7448
7449 bool
7450 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
7451 {
7452   if (Sloc == No_Location)
7453     return false;
7454
7455   if (Sloc <= Standard_Location)
7456     {
7457       *locus = BUILTINS_LOCATION;
7458       return false;
7459     }
7460   else
7461     {
7462       Source_File_Index file = Get_Source_File_Index (Sloc);
7463       Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
7464       Column_Number column = Get_Column_Number (Sloc);
7465       struct line_map *map = &line_table->maps[file - 1];
7466
7467       /* Translate the location according to the line-map.h formula.  */
7468       *locus = map->start_location
7469                 + ((line - map->to_line) << map->column_bits)
7470                 + (column & ((1 << map->column_bits) - 1));
7471     }
7472
7473   ref_filename
7474     = IDENTIFIER_POINTER
7475       (get_identifier
7476        (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
7477
7478   return true;
7479 }
7480
7481 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
7482    don't do anything if it doesn't correspond to a source location.  */
7483
7484 static void
7485 set_expr_location_from_node (tree node, Node_Id gnat_node)
7486 {
7487   location_t locus;
7488
7489   if (!Sloc_to_locus (Sloc (gnat_node), &locus))
7490     return;
7491
7492   SET_EXPR_LOCATION (node, locus);
7493 }
7494 \f
7495 /* Return a colon-separated list of encodings contained in encoded Ada
7496    name.  */
7497
7498 static const char *
7499 extract_encoding (const char *name)
7500 {
7501   char *encoding = GGC_NEWVEC (char, strlen (name));
7502   get_encoding (name, encoding);
7503   return encoding;
7504 }
7505
7506 /* Extract the Ada name from an encoded name.  */
7507
7508 static const char *
7509 decode_name (const char *name)
7510 {
7511   char *decoded = GGC_NEWVEC (char, strlen (name) * 2 + 60);
7512   __gnat_decode (name, decoded, 0);
7513   return decoded;
7514 }
7515 \f
7516 /* Post an error message.  MSG is the error message, properly annotated.
7517    NODE is the node at which to post the error and the node to use for the
7518    "&" substitution.  */
7519
7520 void
7521 post_error (const char *msg, Node_Id node)
7522 {
7523   String_Template temp;
7524   Fat_Pointer fp;
7525
7526   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7527   fp.Array = msg, fp.Bounds = &temp;
7528   if (Present (node))
7529     Error_Msg_N (fp, node);
7530 }
7531
7532 /* Similar, but NODE is the node at which to post the error and ENT
7533    is the node to use for the "&" substitution.  */
7534
7535 void
7536 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
7537 {
7538   String_Template temp;
7539   Fat_Pointer fp;
7540
7541   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7542   fp.Array = msg, fp.Bounds = &temp;
7543   if (Present (node))
7544     Error_Msg_NE (fp, node, ent);
7545 }
7546
7547 /* Similar, but NODE is the node at which to post the error, ENT is the node
7548    to use for the "&" substitution, and N is the number to use for the ^.  */
7549
7550 void
7551 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
7552 {
7553   String_Template temp;
7554   Fat_Pointer fp;
7555
7556   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7557   fp.Array = msg, fp.Bounds = &temp;
7558   Error_Msg_Uint_1 = UI_From_Int (n);
7559
7560   if (Present (node))
7561     Error_Msg_NE (fp, node, ent);
7562 }
7563 \f
7564 /* Similar to post_error_ne_num, but T is a GCC tree representing the
7565    number to write.  If the tree represents a constant that fits within
7566    a host integer, the text inside curly brackets in MSG will be output
7567    (presumably including a '^').  Otherwise that text will not be output
7568    and the text inside square brackets will be output instead.  */
7569
7570 void
7571 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
7572 {
7573   char *newmsg = XALLOCAVEC (char, strlen (msg) + 1);
7574   String_Template temp = {1, 0};
7575   Fat_Pointer fp;
7576   char start_yes, end_yes, start_no, end_no;
7577   const char *p;
7578   char *q;
7579
7580   fp.Array = newmsg, fp.Bounds = &temp;
7581
7582   if (host_integerp (t, 1)
7583 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
7584       &&
7585       compare_tree_int
7586       (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
7587 #endif
7588       )
7589     {
7590       Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
7591       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
7592     }
7593   else
7594     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
7595
7596   for (p = msg, q = newmsg; *p; p++)
7597     {
7598       if (*p == start_yes)
7599         for (p++; *p != end_yes; p++)
7600           *q++ = *p;
7601       else if (*p == start_no)
7602         for (p++; *p != end_no; p++)
7603           ;
7604       else
7605         *q++ = *p;
7606     }
7607
7608   *q = 0;
7609
7610   temp.High_Bound = strlen (newmsg);
7611   if (Present (node))
7612     Error_Msg_NE (fp, node, ent);
7613 }
7614
7615 /* Similar to post_error_ne_tree, except that NUM is a second
7616    integer to write in the message.  */
7617
7618 void
7619 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
7620                       int num)
7621 {
7622   Error_Msg_Uint_2 = UI_From_Int (num);
7623   post_error_ne_tree (msg, node, ent, t);
7624 }
7625 \f
7626 /* Initialize the table that maps GNAT codes to GCC codes for simple
7627    binary and unary operations.  */
7628
7629 static void
7630 init_code_table (void)
7631 {
7632   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
7633   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
7634
7635   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
7636   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
7637   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
7638   gnu_codes[N_Op_Eq] = EQ_EXPR;
7639   gnu_codes[N_Op_Ne] = NE_EXPR;
7640   gnu_codes[N_Op_Lt] = LT_EXPR;
7641   gnu_codes[N_Op_Le] = LE_EXPR;
7642   gnu_codes[N_Op_Gt] = GT_EXPR;
7643   gnu_codes[N_Op_Ge] = GE_EXPR;
7644   gnu_codes[N_Op_Add] = PLUS_EXPR;
7645   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
7646   gnu_codes[N_Op_Multiply] = MULT_EXPR;
7647   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
7648   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
7649   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
7650   gnu_codes[N_Op_Abs] = ABS_EXPR;
7651   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
7652   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
7653   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
7654   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
7655   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
7656   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
7657 }
7658
7659 /* Return a label to branch to for the exception type in KIND or NULL_TREE
7660    if none.  */
7661
7662 tree
7663 get_exception_label (char kind)
7664 {
7665   if (kind == N_Raise_Constraint_Error)
7666     return TREE_VALUE (gnu_constraint_error_label_stack);
7667   else if (kind == N_Raise_Storage_Error)
7668     return TREE_VALUE (gnu_storage_error_label_stack);
7669   else if (kind == N_Raise_Program_Error)
7670     return TREE_VALUE (gnu_program_error_label_stack);
7671   else
7672     return NULL_TREE;
7673 }
7674
7675 #include "gt-ada-trans.h"