gcc/ada/gcc-interface/trans.c

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