gcc/ada/gcc-interface/trans.c

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