gcc/ada/gcc-interface/trans.c

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