gcc/ada/gcc-interface/trans.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                T R A N S                                 *
   6  *                                                                          *
   7  *                          C Implementation File                           *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2010, Free Software Foundation, Inc.         *
  10  *                                                                          *
  11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  12  * terms of the  GNU General Public License as published  by the Free Soft- *
  13  * ware  Foundation;  either version 3,  or (at your option) any later ver- *
  14  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  15  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  16  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  17  * for  more details.  You should have  received  a copy of the GNU General *
  18  * Public License  distributed  with GNAT;  see file  COPYING3.  If not see *
  19  * <http://www.gnu.org/licenses/>.                                          *
  20  *                                                                          *
  21  * GNAT was originally developed  by the GNAT team at  New York University. *
  22  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  23  *                                                                          *
  24  ****************************************************************************/
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "tm.h"
  30 #include "tree.h"
  31 #include "flags.h"
  32 #include "expr.h"
  33 #include "ggc.h"
  34 #include "output.h"
  35 #include "tree-iterator.h"
  36 #include "gimple.h"
  37
  38 #include "ada.h"
  39 #include "adadecode.h"
  40 #include "types.h"
  41 #include "atree.h"
  42 #include "elists.h"
  43 #include "namet.h"
  44 #include "nlists.h"
  45 #include "snames.h"
  46 #include "stringt.h"
  47 #include "uintp.h"
  48 #include "urealp.h"
  49 #include "fe.h"
  50 #include "sinfo.h"
  51 #include "einfo.h"
  52 #include "gadaint.h"
  53 #include "ada-tree.h"
  54 #include "gigi.h"
  55
  56 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
  57    for fear of running out of stack space.  If we need more, we use xmalloc
  58    instead.  */
  59 #define ALLOCA_THRESHOLD 1000
  60
  61 /* Let code below know whether we are targetting VMS without need of
  62    intrusive preprocessor directives.  */
  63 #ifndef TARGET_ABI_OPEN_VMS
  64 #define TARGET_ABI_OPEN_VMS 0
  65 #endif
  66
  67 /* For efficient float-to-int rounding, it is necessary to know whether
  68    floating-point arithmetic may use wider intermediate results.  When
  69    FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
  70    that arithmetic does not widen if double precision is emulated.  */
  71 #ifndef FP_ARITH_MAY_WIDEN
  72 #if defined(HAVE_extendsfdf2)
  73 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
  74 #else
  75 #define FP_ARITH_MAY_WIDEN 0
  76 #endif
  77 #endif
  78
  79 /* Pointers to front-end tables accessed through macros.  */
  80 struct Node *Nodes_Ptr;
  81 Node_Id *Next_Node_Ptr;
  82 Node_Id *Prev_Node_Ptr;
  83 struct Elist_Header *Elists_Ptr;
  84 struct Elmt_Item *Elmts_Ptr;
  85 struct String_Entry *Strings_Ptr;
  86 Char_Code *String_Chars_Ptr;
  87 struct List_Header *List_Headers_Ptr;
  88
  89 /* Highest number in the front-end node table.  */
  90 int max_gnat_nodes;
  91
  92 /* Current node being treated, in case abort called.  */
  93 Node_Id error_gnat_node;
  94
  95 /* True when gigi is being called on an analyzed but unexpanded
  96    tree, and the only purpose of the call is to properly annotate
  97    types with representation information.  */
  98 bool type_annotate_only;
  99
 100 /* Current filename without path.  */
 101 const char *ref_filename;
 102
 103 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
 104    of unconstrained array IN parameters to avoid emitting a great deal of
 105    redundant instructions to recompute them each time.  */
 106 struct GTY (()) parm_attr_d {
 107   int id; /* GTY doesn't like Entity_Id.  */
 108   int dim;
 109   tree first;
 110   tree last;
 111   tree length;
 112 };
 113
 114 typedef struct parm_attr_d *parm_attr;
 115
 116 DEF_VEC_P(parm_attr);
 117 DEF_VEC_ALLOC_P(parm_attr,gc);
 118
 119 struct GTY(()) language_function {
 120   VEC(parm_attr,gc) *parm_attr_cache;
 121 };
 122
 123 #define f_parm_attr_cache \
 124   DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
 125
 126 /* A structure used to gather together information about a statement group.
 127    We use this to gather related statements, for example the "then" part
 128    of a IF.  In the case where it represents a lexical scope, we may also
 129    have a BLOCK node corresponding to it and/or cleanups.  */
 130
 131 struct GTY((chain_next ("%h.previous"))) stmt_group {
 132   struct stmt_group *previous;  /* Previous code group.  */
 133   tree stmt_list;               /* List of statements for this code group.  */
 134   tree block;                   /* BLOCK for this code group, if any.  */
 135   tree cleanups;                /* Cleanups for this code group, if any.  */
 136 };
 137
 138 static GTY(()) struct stmt_group *current_stmt_group;
 139
 140 /* List of unused struct stmt_group nodes.  */
 141 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
 142
 143 /* A structure used to record information on elaboration procedures
 144    we've made and need to process.
 145
 146    ??? gnat_node should be Node_Id, but gengtype gets confused.  */
 147
 148 struct GTY((chain_next ("%h.next"))) elab_info {
 149   struct elab_info *next;       /* Pointer to next in chain.  */
 150   tree elab_proc;               /* Elaboration procedure.  */
 151   int gnat_node;                /* The N_Compilation_Unit.  */
 152 };
 153
 154 static GTY(()) struct elab_info *elab_info_list;
 155
 156 /* Free list of TREE_LIST nodes used for stacks.  */
 157 static GTY((deletable)) tree gnu_stack_free_list;
 158
 159 /* List of TREE_LIST nodes representing a stack of exception pointer
 160    variables.  TREE_VALUE is the VAR_DECL that stores the address of
 161    the raised exception.  Nonzero means we are in an exception
 162    handler.  Not used in the zero-cost case.  */
 163 static GTY(()) tree gnu_except_ptr_stack;
 164
 165 /* List of TREE_LIST nodes used to store the current elaboration procedure
 166    decl.  TREE_VALUE is the decl.  */
 167 static GTY(()) tree gnu_elab_proc_stack;
 168
 169 /* Variable that stores a list of labels to be used as a goto target instead of
 170    a return in some functions.  See processing for N_Subprogram_Body.  */
 171 static GTY(()) tree gnu_return_label_stack;
 172
 173 /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes.
 174    TREE_VALUE of each entry is the label of the corresponding LOOP_STMT.  */
 175 static GTY(()) tree gnu_loop_label_stack;
 176
 177 /* List of TREE_LIST nodes representing labels for switch statements.
 178    TREE_VALUE of each entry is the label at the end of the switch.  */
 179 static GTY(()) tree gnu_switch_label_stack;
 180
 181 /* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label.  */
 182 static GTY(()) tree gnu_constraint_error_label_stack;
 183 static GTY(()) tree gnu_storage_error_label_stack;
 184 static GTY(()) tree gnu_program_error_label_stack;
 185
 186 /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
 187 static enum tree_code gnu_codes[Number_Node_Kinds];
 188
 189 static void init_code_table (void);
 190 static void Compilation_Unit_to_gnu (Node_Id);
 191 static void record_code_position (Node_Id);
 192 static void insert_code_for (Node_Id);
 193 static void add_cleanup (tree, Node_Id);
 194 static tree unshare_save_expr (tree *, int *, void *);
 195 static void add_stmt_list (List_Id);
 196 static void push_exception_label_stack (tree *, Entity_Id);
 197 static tree build_stmt_group (List_Id, bool);
 198 static void push_stack (tree *, tree, tree);
 199 static void pop_stack (tree *);
 200 static enum gimplify_status gnat_gimplify_stmt (tree *);
 201 static void elaborate_all_entities (Node_Id);
 202 static void process_freeze_entity (Node_Id);
 203 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
 204 static tree emit_range_check (tree, Node_Id, Node_Id);
 205 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
 206 static tree emit_check (tree, tree, int, Node_Id);
 207 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
 208 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
 209 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
 210 static bool smaller_form_type_p (tree, tree);
 211 static bool addressable_p (tree, tree);
 212 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 213 static tree extract_values (tree, tree);
 214 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
 215 static tree maybe_implicit_deref (tree);
 216 static void set_expr_location_from_node (tree, Node_Id);
 217 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
 218
 219 /* Hooks for debug info back-ends, only supported and used in a restricted set
 220    of configurations.  */
 221 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
 222 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
 223 \f
 224 /* This is the main program of the back-end.  It sets up all the table
 225    structures and then generates code.  */
 226
 227 void
 228 gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
 229       struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
 230       struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
 231       struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
 232       struct List_Header *list_headers_ptr, Nat number_file,
 233       struct File_Info_Type *file_info_ptr,
 234       Entity_Id standard_boolean, Entity_Id standard_integer,
 235       Entity_Id standard_character, Entity_Id standard_long_long_float,
 236       Entity_Id standard_exception_type, Int gigi_operating_mode)
 237 {
 238   Entity_Id gnat_literal;
 239   tree long_long_float_type, exception_type, t;
 240   tree int64_type = gnat_type_for_size (64, 0);
 241   struct elab_info *info;
 242   int i;
 243
 244   max_gnat_nodes = max_gnat_node;
 245
 246   Nodes_Ptr = nodes_ptr;
 247   Next_Node_Ptr = next_node_ptr;
 248   Prev_Node_Ptr = prev_node_ptr;
 249   Elists_Ptr = elists_ptr;
 250   Elmts_Ptr = elmts_ptr;
 251   Strings_Ptr = strings_ptr;
 252   String_Chars_Ptr = string_chars_ptr;
 253   List_Headers_Ptr = list_headers_ptr;
 254
 255   type_annotate_only = (gigi_operating_mode == 1);
 256
 257   gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
 258
 259   /* Declare the name of the compilation unit as the first global
 260      name in order to make the middle-end fully deterministic.  */
 261   t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
 262   first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
 263
 264   for (i = 0; i < number_file; i++)
 265     {
 266       /* Use the identifier table to make a permanent copy of the filename as
 267          the name table gets reallocated after Gigi returns but before all the
 268          debugging information is output.  The __gnat_to_canonical_file_spec
 269          call translates filenames from pragmas Source_Reference that contain
 270          host style syntax not understood by gdb.  */
 271       const char *filename
 272         = IDENTIFIER_POINTER
 273            (get_identifier
 274             (__gnat_to_canonical_file_spec
 275              (Get_Name_String (file_info_ptr[i].File_Name))));
 276
 277       /* We rely on the order isomorphism between files and line maps.  */
 278       gcc_assert ((int) line_table->used == i);
 279
 280       /* We create the line map for a source file at once, with a fixed number
 281          of columns chosen to avoid jumping over the next power of 2.  */
 282       linemap_add (line_table, LC_ENTER, 0, filename, 1);
 283       linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
 284       linemap_position_for_column (line_table, 252 - 1);
 285       linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
 286     }
 287
 288   /* Initialize ourselves.  */
 289   init_code_table ();
 290   init_gnat_to_gnu ();
 291   init_dummy_type ();
 292
 293   /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
 294      errors.  */
 295   if (type_annotate_only)
 296     {
 297       TYPE_SIZE (void_type_node) = bitsize_zero_node;
 298       TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
 299     }
 300
 301   /* If the GNU type extensions to DWARF are available, setup the hooks.  */
 302 #if defined (DWARF2_DEBUGGING_INFO) && defined (DWARF2_GNU_TYPE_EXTENSIONS)
 303   /* We condition the name demangling and the generation of type encoding
 304      strings on -gdwarf+ and always set descriptive types on.  */
 305   if (use_gnu_debug_info_extensions)
 306     {
 307       dwarf2out_set_type_encoding_func (extract_encoding);
 308       dwarf2out_set_demangle_name_func (decode_name);
 309     }
 310   dwarf2out_set_descriptive_type_func (get_parallel_type);
 311 #endif
 312
 313   /* Enable GNAT stack checking method if needed */
 314   if (!Stack_Check_Probes_On_Target)
 315     set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
 316
 317   /* Retrieve alignment settings.  */
 318   double_float_alignment = get_target_double_float_alignment ();
 319   double_scalar_alignment = get_target_double_scalar_alignment ();
 320
 321   /* Record the builtin types.  Define `integer' and `character' first so that
 322      dbx will output them first.  */
 323   record_builtin_type ("integer", integer_type_node);
 324   record_builtin_type ("character", unsigned_char_type_node);
 325   record_builtin_type ("boolean", boolean_type_node);
 326   record_builtin_type ("void", void_type_node);
 327
 328   /* Save the type we made for integer as the type for Standard.Integer.  */
 329   save_gnu_tree (Base_Type (standard_integer),
 330                  TYPE_NAME (integer_type_node),
 331                  false);
 332
 333   /* Likewise for character as the type for Standard.Character.  */
 334   save_gnu_tree (Base_Type (standard_character),
 335                  TYPE_NAME (unsigned_char_type_node),
 336                  false);
 337
 338   /* Likewise for boolean as the type for Standard.Boolean.  */
 339   save_gnu_tree (Base_Type (standard_boolean),
 340                  TYPE_NAME (boolean_type_node),
 341                  false);
 342   gnat_literal = First_Literal (Base_Type (standard_boolean));
 343   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 344   gcc_assert (t == boolean_false_node);
 345   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 346                        boolean_type_node, t, true, false, false, false,
 347                        NULL, gnat_literal);
 348   DECL_IGNORED_P (t) = 1;
 349   save_gnu_tree (gnat_literal, t, false);
 350   gnat_literal = Next_Literal (gnat_literal);
 351   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 352   gcc_assert (t == boolean_true_node);
 353   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 354                        boolean_type_node, t, true, false, false, false,
 355                        NULL, gnat_literal);
 356   DECL_IGNORED_P (t) = 1;
 357   save_gnu_tree (gnat_literal, t, false);
 358
 359   void_ftype = build_function_type (void_type_node, NULL_TREE);
 360   ptr_void_ftype = build_pointer_type (void_ftype);
 361
 362   /* Now declare runtime functions.  */
 363   t = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
 364
 365   /* malloc is a function declaration tree for a function to allocate
 366      memory.  */
 367   malloc_decl
 368     = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
 369                            build_function_type (ptr_void_type_node,
 370                                                 tree_cons (NULL_TREE,
 371                                                            sizetype, t)),
 372                            NULL_TREE, false, true, true, NULL, Empty);
 373   DECL_IS_MALLOC (malloc_decl) = 1;
 374
 375   /* malloc32 is a function declaration tree for a function to allocate
 376      32-bit memory on a 64-bit system.  Needed only on 64-bit VMS.  */
 377   malloc32_decl
 378     = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
 379                            build_function_type (ptr_void_type_node,
 380                                                 tree_cons (NULL_TREE,
 381                                                            sizetype, t)),
 382                            NULL_TREE, false, true, true, NULL, Empty);
 383   DECL_IS_MALLOC (malloc32_decl) = 1;
 384
 385   /* free is a function declaration tree for a function to free memory.  */
 386   free_decl
 387     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
 388                            build_function_type (void_type_node,
 389                                                 tree_cons (NULL_TREE,
 390                                                            ptr_void_type_node,
 391                                                            t)),
 392                            NULL_TREE, false, true, true, NULL, Empty);
 393
 394   /* This is used for 64-bit multiplication with overflow checking.  */
 395   mulv64_decl
 396     = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
 397                            build_function_type_list (int64_type, int64_type,
 398                                                      int64_type, NULL_TREE),
 399                            NULL_TREE, false, true, true, NULL, Empty);
 400
 401   /* Name of the _Parent field in tagged record types.  */
 402   parent_name_id = get_identifier (Get_Name_String (Name_uParent));
 403
 404   /* Make the types and functions used for exception processing.  */
 405   jmpbuf_type
 406     = build_array_type (gnat_type_for_mode (Pmode, 0),
 407                         build_index_type (size_int (5)));
 408   record_builtin_type ("JMPBUF_T", jmpbuf_type);
 409   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
 410
 411   /* Functions to get and set the jumpbuf pointer for the current thread.  */
 412   get_jmpbuf_decl
 413     = create_subprog_decl
 414     (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
 415      NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
 416      NULL_TREE, false, true, true, NULL, Empty);
 417   /* Avoid creating superfluous edges to __builtin_setjmp receivers.  */
 418   DECL_PURE_P (get_jmpbuf_decl) = 1;
 419   DECL_IGNORED_P (get_jmpbuf_decl) = 1;
 420
 421   set_jmpbuf_decl
 422     = create_subprog_decl
 423     (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
 424      NULL_TREE,
 425      build_function_type (void_type_node,
 426                           tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
 427      NULL_TREE, false, true, true, NULL, Empty);
 428   DECL_IGNORED_P (set_jmpbuf_decl) = 1;
 429
 430   /* setjmp returns an integer and has one operand, which is a pointer to
 431      a jmpbuf.  */
 432   setjmp_decl
 433     = create_subprog_decl
 434       (get_identifier ("__builtin_setjmp"), NULL_TREE,
 435        build_function_type (integer_type_node,
 436                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, t)),
 437        NULL_TREE, false, true, true, NULL, Empty);
 438   DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
 439   DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
 440
 441   /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
 442      address.  */
 443   update_setjmp_buf_decl
 444     = create_subprog_decl
 445       (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
 446        build_function_type (void_type_node,
 447                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, t)),
 448        NULL_TREE, false, true, true, NULL, Empty);
 449   DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
 450   DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
 451
 452   /* Hooks to call when entering/leaving an exception handler.  */
 453   begin_handler_decl
 454     = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
 455                            build_function_type (void_type_node,
 456                                                 tree_cons (NULL_TREE,
 457                                                            ptr_void_type_node,
 458                                                            t)),
 459                            NULL_TREE, false, true, true, NULL, Empty);
 460   DECL_IGNORED_P (begin_handler_decl) = 1;
 461
 462   end_handler_decl
 463     = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
 464                            build_function_type (void_type_node,
 465                                                 tree_cons (NULL_TREE,
 466                                                            ptr_void_type_node,
 467                                                            t)),
 468                            NULL_TREE, false, true, true, NULL, Empty);
 469   DECL_IGNORED_P (end_handler_decl) = 1;
 470
 471   /* If in no exception handlers mode, all raise statements are redirected to
 472      __gnat_last_chance_handler.  No need to redefine raise_nodefer_decl since
 473      this procedure will never be called in this mode.  */
 474   if (No_Exception_Handlers_Set ())
 475     {
 476       tree decl
 477         = create_subprog_decl
 478           (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
 479            build_function_type (void_type_node,
 480                                 tree_cons (NULL_TREE,
 481                                            build_pointer_type
 482                                            (unsigned_char_type_node),
 483                                            tree_cons (NULL_TREE,
 484                                                       integer_type_node,
 485                                                       t))),
 486            NULL_TREE, false, true, true, NULL, Empty);
 487
 488       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 489         gnat_raise_decls[i] = decl;
 490     }
 491   else
 492     /* Otherwise, make one decl for each exception reason.  */
 493     for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 494       {
 495         char name[17];
 496
 497         sprintf (name, "__gnat_rcheck_%.2d", i);
 498         gnat_raise_decls[i]
 499           = create_subprog_decl
 500             (get_identifier (name), NULL_TREE,
 501              build_function_type (void_type_node,
 502                                   tree_cons (NULL_TREE,
 503                                              build_pointer_type
 504                                              (unsigned_char_type_node),
 505                                              tree_cons (NULL_TREE,
 506                                                         integer_type_node,
 507                                                         t))),
 508              NULL_TREE, false, true, true, NULL, Empty);
 509       }
 510
 511   for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 512     {
 513       TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
 514       TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
 515       TREE_TYPE (gnat_raise_decls[i])
 516         = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
 517                                 TYPE_QUAL_VOLATILE);
 518     }
 519
 520   /* Set the types that GCC and Gigi use from the front end.  */
 521   exception_type
 522     = gnat_to_gnu_entity (Base_Type (standard_exception_type),  NULL_TREE, 0);
 523   except_type_node = TREE_TYPE (exception_type);
 524
 525   /* Make other functions used for exception processing.  */
 526   get_excptr_decl
 527     = create_subprog_decl
 528     (get_identifier ("system__soft_links__get_gnat_exception"),
 529      NULL_TREE,
 530      build_function_type (build_pointer_type (except_type_node), NULL_TREE),
 531      NULL_TREE, false, true, true, NULL, Empty);
 532   /* Avoid creating superfluous edges to __builtin_setjmp receivers.  */
 533   DECL_PURE_P (get_excptr_decl) = 1;
 534
 535   raise_nodefer_decl
 536     = create_subprog_decl
 537       (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
 538        build_function_type (void_type_node,
 539                             tree_cons (NULL_TREE,
 540                                        build_pointer_type (except_type_node),
 541                                        t)),
 542        NULL_TREE, false, true, true, NULL, Empty);
 543
 544   /* Indicate that these never return.  */
 545   TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
 546   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
 547   TREE_TYPE (raise_nodefer_decl)
 548     = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
 549                             TYPE_QUAL_VOLATILE);
 550
 551   /* Build the special descriptor type and its null node if needed.  */
 552   if (TARGET_VTABLE_USES_DESCRIPTORS)
 553     {
 554       tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
 555       tree field_list = NULL_TREE, null_list = NULL_TREE;
 556       int j;
 557
 558       fdesc_type_node = make_node (RECORD_TYPE);
 559
 560       for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
 561         {
 562           tree field
 563             = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
 564                                  NULL_TREE, NULL_TREE, 0, 1);
 565           TREE_CHAIN (field) = field_list;
 566           field_list = field;
 567           null_list = tree_cons (field, null_node, null_list);
 568         }
 569
 570       finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
 571       record_builtin_type ("descriptor", fdesc_type_node);
 572       null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
 573     }
 574
 575   long_long_float_type
 576     = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
 577
 578   if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
 579     {
 580       /* In this case, the builtin floating point types are VAX float,
 581          so make up a type for use.  */
 582       longest_float_type_node = make_node (REAL_TYPE);
 583       TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
 584       layout_type (longest_float_type_node);
 585       record_builtin_type ("longest float type", longest_float_type_node);
 586     }
 587   else
 588     longest_float_type_node = TREE_TYPE (long_long_float_type);
 589
 590   /* Dummy objects to materialize "others" and "all others" in the exception
 591      tables.  These are exported by a-exexpr.adb, so see this unit for the
 592      types to use.  */
 593   others_decl
 594     = create_var_decl (get_identifier ("OTHERS"),
 595                        get_identifier ("__gnat_others_value"),
 596                        integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
 597
 598   all_others_decl
 599     = create_var_decl (get_identifier ("ALL_OTHERS"),
 600                        get_identifier ("__gnat_all_others_value"),
 601                        integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
 602
 603   main_identifier_node = get_identifier ("main");
 604
 605   /* Install the builtins we might need, either internally or as
 606      user available facilities for Intrinsic imports.  */
 607   gnat_install_builtins ();
 608
 609   gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 610   gnu_constraint_error_label_stack
 611     = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 612   gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 613   gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 614
 615   /* Process any Pragma Ident for the main unit.  */
 616 #ifdef ASM_OUTPUT_IDENT
 617   if (Present (Ident_String (Main_Unit)))
 618     ASM_OUTPUT_IDENT
 619       (asm_out_file,
 620        TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
 621 #endif
 622
 623   /* If we are using the GCC exception mechanism, let GCC know.  */
 624   if (Exception_Mechanism == Back_End_Exceptions)
 625     gnat_init_gcc_eh ();
 626
 627   /* Now translate the compilation unit proper.  */
 628   Compilation_Unit_to_gnu (gnat_root);
 629
 630   /* Finally see if we have any elaboration procedures to deal with.  */
 631   for (info = elab_info_list; info; info = info->next)
 632     {
 633       tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
 634
 635       /* Unshare SAVE_EXPRs between subprograms.  These are not unshared by
 636          the gimplifier for obvious reasons, but it turns out that we need to
 637          unshare them for the global level because of SAVE_EXPRs made around
 638          checks for global objects and around allocators for global objects
 639          of variable size, in order to prevent node sharing in the underlying
 640          expression.  Note that this implicitly assumes that the SAVE_EXPR
 641          nodes themselves are not shared between subprograms, which would be
 642          an upstream bug for which we would not change the outcome.  */
 643       walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL);
 644
 645       /* We should have a BIND_EXPR but it may not have any statements in it.
 646          If it doesn't have any, we have nothing to do except for setting the
 647          flag on the GNAT node.  Otherwise, process the function as others.  */
 648       gnu_stmts = gnu_body;
 649       if (TREE_CODE (gnu_stmts) == BIND_EXPR)
 650         gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
 651       if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
 652         Set_Has_No_Elaboration_Code (info->gnat_node, 1);
 653       else
 654         {
 655           begin_subprog_body (info->elab_proc);
 656           end_subprog_body (gnu_body);
 657         }
 658     }
 659
 660   /* We cannot track the location of errors past this point.  */
 661   error_gnat_node = Empty;
 662 }
 663 \f
 664 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
 665    an N_Attribute_Reference.  */
 666
 667 static int
 668 lvalue_required_for_attribute_p (Node_Id gnat_node)
 669 {
 670   switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
 671     {
 672     case Attr_Pos:
 673     case Attr_Val:
 674     case Attr_Pred:
 675     case Attr_Succ:
 676     case Attr_First:
 677     case Attr_Last:
 678     case Attr_Range_Length:
 679     case Attr_Length:
 680     case Attr_Object_Size:
 681     case Attr_Value_Size:
 682     case Attr_Component_Size:
 683     case Attr_Max_Size_In_Storage_Elements:
 684     case Attr_Min:
 685     case Attr_Max:
 686     case Attr_Null_Parameter:
 687     case Attr_Passed_By_Reference:
 688     case Attr_Mechanism_Code:
 689       return 0;
 690
 691     case Attr_Address:
 692     case Attr_Access:
 693     case Attr_Unchecked_Access:
 694     case Attr_Unrestricted_Access:
 695     case Attr_Code_Address:
 696     case Attr_Pool_Address:
 697     case Attr_Size:
 698     case Attr_Alignment:
 699     case Attr_Bit_Position:
 700     case Attr_Position:
 701     case Attr_First_Bit:
 702     case Attr_Last_Bit:
 703     case Attr_Bit:
 704     default:
 705       return 1;
 706     }
 707 }
 708
 709 /* Return a positive value if an lvalue is required for GNAT_NODE.  GNU_TYPE
 710    is the type that will be used for GNAT_NODE in the translated GNU tree.
 711    CONSTANT indicates whether the underlying object represented by GNAT_NODE
 712    is constant in the Ada sense.  If it is, ADDRESS_OF_CONSTANT indicates
 713    whether its value is the address of a constant and ALIASED whether it is
 714    aliased.  If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
 715
 716    The function climbs up the GNAT tree starting from the node and returns 1
 717    upon encountering a node that effectively requires an lvalue downstream.
 718    It returns int instead of bool to facilitate usage in non-purely binary
 719    logic contexts.  */
 720
 721 static int
 722 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
 723                    bool address_of_constant, bool aliased)
 724 {
 725   Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
 726
 727   switch (Nkind (gnat_parent))
 728     {
 729     case N_Reference:
 730       return 1;
 731
 732     case N_Attribute_Reference:
 733       return lvalue_required_for_attribute_p (gnat_parent);
 734
 735     case N_Parameter_Association:
 736     case N_Function_Call:
 737     case N_Procedure_Call_Statement:
 738       /* If the parameter is by reference, an lvalue is required.  */
 739       return (!constant
 740               || must_pass_by_ref (gnu_type)
 741               || default_pass_by_ref (gnu_type));
 742
 743     case N_Indexed_Component:
 744       /* Only the array expression can require an lvalue.  */
 745       if (Prefix (gnat_parent) != gnat_node)
 746         return 0;
 747
 748       /* ??? Consider that referencing an indexed component with a
 749          non-constant index forces the whole aggregate to memory.
 750          Note that N_Integer_Literal is conservative, any static
 751          expression in the RM sense could probably be accepted.  */
 752       for (gnat_temp = First (Expressions (gnat_parent));
 753            Present (gnat_temp);
 754            gnat_temp = Next (gnat_temp))
 755         if (Nkind (gnat_temp) != N_Integer_Literal)
 756           return 1;
 757
 758       /* ... fall through ... */
 759
 760     case N_Slice:
 761       /* Only the array expression can require an lvalue.  */
 762       if (Prefix (gnat_parent) != gnat_node)
 763         return 0;
 764
 765       aliased |= Has_Aliased_Components (Etype (gnat_node));
 766       return lvalue_required_p (gnat_parent, gnu_type, constant,
 767                                 address_of_constant, aliased);
 768
 769     case N_Selected_Component:
 770       aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
 771       return lvalue_required_p (gnat_parent, gnu_type, constant,
 772                                 address_of_constant, aliased);
 773
 774     case N_Object_Renaming_Declaration:
 775       /* We need to make a real renaming only if the constant object is
 776          aliased or if we may use a renaming pointer; otherwise we can
 777          optimize and return the rvalue.  We make an exception if the object
 778          is an identifier since in this case the rvalue can be propagated
 779          attached to the CONST_DECL.  */
 780       return (!constant
 781               || aliased
 782               /* This should match the constant case of the renaming code.  */
 783               || Is_Composite_Type
 784                  (Underlying_Type (Etype (Name (gnat_parent))))
 785               || Nkind (Name (gnat_parent)) == N_Identifier);
 786
 787     case N_Object_Declaration:
 788       /* We cannot use a constructor if this is an atomic object because
 789          the actual assignment might end up being done component-wise.  */
 790       return (!constant
 791               ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 792                  && Is_Atomic (Defining_Entity (gnat_parent)))
 793               /* We don't use a constructor if this is a class-wide object
 794                  because the effective type of the object is the equivalent
 795                  type of the class-wide subtype and it smashes most of the
 796                  data into an array of bytes to which we cannot convert.  */
 797               || Ekind ((Etype (Defining_Entity (gnat_parent))))
 798                  == E_Class_Wide_Subtype);
 799
 800     case N_Assignment_Statement:
 801       /* We cannot use a constructor if the LHS is an atomic object because
 802          the actual assignment might end up being done component-wise.  */
 803       return (!constant
 804               || Name (gnat_parent) == gnat_node
 805               || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 806                   && Is_Atomic (Entity (Name (gnat_parent)))));
 807
 808     case N_Type_Conversion:
 809     case N_Qualified_Expression:
 810       /* We must look through all conversions for composite types because we
 811          may need to bypass an intermediate conversion to a narrower record
 812          type that is generated for a formal conversion, e.g. the conversion
 813          to the root type of a hierarchy of tagged types generated for the
 814          formal conversion to the class-wide type.  */
 815       if (!Is_Composite_Type (Underlying_Type (Etype (gnat_node))))
 816         return 0;
 817
 818       /* ... fall through ... */
 819
 820     case N_Unchecked_Type_Conversion:
 821       return (!constant
 822               || lvalue_required_p (gnat_parent,
 823                                     get_unpadded_type (Etype (gnat_parent)),
 824                                     constant, address_of_constant, aliased));
 825
 826     case N_Allocator:
 827       /* We should only reach here through the N_Qualified_Expression case
 828          and, therefore, only for composite types.  Force an lvalue since
 829          a block-copy to the newly allocated area of memory is made.  */
 830       return 1;
 831
 832    case N_Explicit_Dereference:
 833       /* We look through dereferences for address of constant because we need
 834          to handle the special cases listed above.  */
 835       if (constant && address_of_constant)
 836         return lvalue_required_p (gnat_parent,
 837                                   get_unpadded_type (Etype (gnat_parent)),
 838                                   true, false, true);
 839
 840       /* ... fall through ... */
 841
 842     default:
 843       return 0;
 844     }
 845
 846   gcc_unreachable ();
 847 }
 848
 849 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
 850    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer
 851    to where we should place the result type.  */
 852
 853 static tree
 854 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 855 {
 856   Node_Id gnat_temp, gnat_temp_type;
 857   tree gnu_result, gnu_result_type;
 858
 859   /* Whether we should require an lvalue for GNAT_NODE.  Needed in
 860      specific circumstances only, so evaluated lazily.  < 0 means
 861      unknown, > 0 means known true, 0 means known false.  */
 862   int require_lvalue = -1;
 863
 864   /* If GNAT_NODE is a constant, whether we should use the initialization
 865      value instead of the constant entity, typically for scalars with an
 866      address clause when the parent doesn't require an lvalue.  */
 867   bool use_constant_initializer = false;
 868
 869   /* If the Etype of this node does not equal the Etype of the Entity,
 870      something is wrong with the entity map, probably in generic
 871      instantiation. However, this does not apply to types. Since we sometime
 872      have strange Ekind's, just do this test for objects. Also, if the Etype of
 873      the Entity is private, the Etype of the N_Identifier is allowed to be the
 874      full type and also we consider a packed array type to be the same as the
 875      original type. Similarly, a class-wide type is equivalent to a subtype of
 876      itself. Finally, if the types are Itypes, one may be a copy of the other,
 877      which is also legal.  */
 878   gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
 879                ? gnat_node : Entity (gnat_node));
 880   gnat_temp_type = Etype (gnat_temp);
 881
 882   gcc_assert (Etype (gnat_node) == gnat_temp_type
 883               || (Is_Packed (gnat_temp_type)
 884                   && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
 885               || (Is_Class_Wide_Type (Etype (gnat_node)))
 886               || (IN (Ekind (gnat_temp_type), Private_Kind)
 887                   && Present (Full_View (gnat_temp_type))
 888                   && ((Etype (gnat_node) == Full_View (gnat_temp_type))
 889                       || (Is_Packed (Full_View (gnat_temp_type))
 890                           && (Etype (gnat_node)
 891                               == Packed_Array_Type (Full_View
 892                                                     (gnat_temp_type))))))
 893               || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
 894               || !(Ekind (gnat_temp) == E_Variable
 895                    || Ekind (gnat_temp) == E_Component
 896                    || Ekind (gnat_temp) == E_Constant
 897                    || Ekind (gnat_temp) == E_Loop_Parameter
 898                    || IN (Ekind (gnat_temp), Formal_Kind)));
 899
 900   /* If this is a reference to a deferred constant whose partial view is an
 901      unconstrained private type, the proper type is on the full view of the
 902      constant, not on the full view of the type, which may be unconstrained.
 903
 904      This may be a reference to a type, for example in the prefix of the
 905      attribute Position, generated for dispatching code (see Make_DT in
 906      exp_disp,adb). In that case we need the type itself, not is parent,
 907      in particular if it is a derived type  */
 908   if (Is_Private_Type (gnat_temp_type)
 909       && Has_Unknown_Discriminants (gnat_temp_type)
 910       && Ekind (gnat_temp) == E_Constant
 911       && Present (Full_View (gnat_temp)))
 912     {
 913       gnat_temp = Full_View (gnat_temp);
 914       gnat_temp_type = Etype (gnat_temp);
 915     }
 916   else
 917     {
 918       /* We want to use the Actual_Subtype if it has already been elaborated,
 919          otherwise the Etype.  Avoid using Actual_Subtype for packed arrays to
 920          simplify things.  */
 921       if ((Ekind (gnat_temp) == E_Constant
 922            || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
 923           && !(Is_Array_Type (Etype (gnat_temp))
 924                && Present (Packed_Array_Type (Etype (gnat_temp))))
 925           && Present (Actual_Subtype (gnat_temp))
 926           && present_gnu_tree (Actual_Subtype (gnat_temp)))
 927         gnat_temp_type = Actual_Subtype (gnat_temp);
 928       else
 929         gnat_temp_type = Etype (gnat_node);
 930     }
 931
 932   /* Expand the type of this identifier first, in case it is an enumeral
 933      literal, which only get made when the type is expanded.  There is no
 934      order-of-elaboration issue here.  */
 935   gnu_result_type = get_unpadded_type (gnat_temp_type);
 936
 937   /* If this is a non-imported scalar constant with an address clause,
 938      retrieve the value instead of a pointer to be dereferenced unless
 939      an lvalue is required.  This is generally more efficient and actually
 940      required if this is a static expression because it might be used
 941      in a context where a dereference is inappropriate, such as a case
 942      statement alternative or a record discriminant.  There is no possible
 943      volatile-ness short-circuit here since Volatile constants must bei
 944      imported per C.6.  */
 945   if (Ekind (gnat_temp) == E_Constant
 946       && Is_Scalar_Type (gnat_temp_type)
 947       && !Is_Imported (gnat_temp)
 948       && Present (Address_Clause (gnat_temp)))
 949     {
 950       require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
 951                                           false, Is_Aliased (gnat_temp));
 952       use_constant_initializer = !require_lvalue;
 953     }
 954
 955   if (use_constant_initializer)
 956     {
 957       /* If this is a deferred constant, the initializer is attached to
 958          the full view.  */
 959       if (Present (Full_View (gnat_temp)))
 960         gnat_temp = Full_View (gnat_temp);
 961
 962       gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
 963     }
 964   else
 965     gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
 966
 967   /* If we are in an exception handler, force this variable into memory to
 968      ensure optimization does not remove stores that appear redundant but are
 969      actually needed in case an exception occurs.
 970
 971      ??? Note that we need not do this if the variable is declared within the
 972      handler, only if it is referenced in the handler and declared in an
 973      enclosing block, but we have no way of testing that right now.
 974
 975      ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
 976      here, but it can now be removed by the Tree aliasing machinery if the
 977      address of the variable is never taken.  All we can do is to make the
 978      variable volatile, which might incur the generation of temporaries just
 979      to access the memory in some circumstances.  This can be avoided for
 980      variables of non-constant size because they are automatically allocated
 981      to memory.  There might be no way of allocating a proper temporary for
 982      them in any case.  We only do this for SJLJ though.  */
 983   if (TREE_VALUE (gnu_except_ptr_stack)
 984       && TREE_CODE (gnu_result) == VAR_DECL
 985       && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST)
 986     TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
 987
 988   /* Some objects (such as parameters passed by reference, globals of
 989      variable size, and renamed objects) actually represent the address
 990      of the object.  In that case, we must do the dereference.  Likewise,
 991      deal with parameters to foreign convention subprograms.  */
 992   if (DECL_P (gnu_result)
 993       && (DECL_BY_REF_P (gnu_result)
 994           || (TREE_CODE (gnu_result) == PARM_DECL
 995               && DECL_BY_COMPONENT_PTR_P (gnu_result))))
 996     {
 997       const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
 998       tree renamed_obj;
 999
1000       if (TREE_CODE (gnu_result) == PARM_DECL
1001           && DECL_BY_COMPONENT_PTR_P (gnu_result))
1002         gnu_result
1003           = build_unary_op (INDIRECT_REF, NULL_TREE,
1004                             convert (build_pointer_type (gnu_result_type),
1005                                      gnu_result));
1006
1007       /* If it's a renaming pointer and we are at the right binding level,
1008          we can reference the renamed object directly, since the renamed
1009          expression has been protected against multiple evaluations.  */
1010       else if (TREE_CODE (gnu_result) == VAR_DECL
1011                && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result))
1012                && (!DECL_RENAMING_GLOBAL_P (gnu_result)
1013                    || global_bindings_p ()))
1014         gnu_result = renamed_obj;
1015
1016       /* Return the underlying CST for a CONST_DECL like a few lines below,
1017          after dereferencing in this case.  */
1018       else if (TREE_CODE (gnu_result) == CONST_DECL)
1019         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
1020                                      DECL_INITIAL (gnu_result));
1021
1022       else
1023         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1024
1025       if (read_only)
1026         TREE_READONLY (gnu_result) = 1;
1027     }
1028
1029   /* The GNAT tree has the type of a function as the type of its result.  Also
1030      use the type of the result if the Etype is a subtype which is nominally
1031      unconstrained.  But remove any padding from the resulting type.  */
1032   if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1033       || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
1034     {
1035       gnu_result_type = TREE_TYPE (gnu_result);
1036       if (TYPE_IS_PADDING_P (gnu_result_type))
1037         gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1038     }
1039
1040   /* If we have a constant declaration and its initializer, try to return the
1041      latter to avoid the need to call fold in lots of places and the need for
1042      elaboration code if this identifier is used as an initializer itself.  */
1043   if (TREE_CONSTANT (gnu_result)
1044       && DECL_P (gnu_result)
1045       && DECL_INITIAL (gnu_result))
1046     {
1047       bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1048                             && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1049       bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1050                                   && DECL_CONST_ADDRESS_P (gnu_result));
1051
1052       /* If there is a (corresponding) variable or this is the address of a
1053          constant, we only want to return the initializer if an lvalue isn't
1054          required.  Evaluate this now if we have not already done so.  */
1055       if ((!constant_only || address_of_constant) && require_lvalue < 0)
1056         require_lvalue
1057           = lvalue_required_p (gnat_node, gnu_result_type, true,
1058                                address_of_constant, Is_Aliased (gnat_temp));
1059
1060       if ((constant_only && !address_of_constant) || !require_lvalue)
1061         gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
1062     }
1063
1064   *gnu_result_type_p = gnu_result_type;
1065
1066   return gnu_result;
1067 }
1068 \f
1069 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
1070    any statements we generate.  */
1071
1072 static tree
1073 Pragma_to_gnu (Node_Id gnat_node)
1074 {
1075   Node_Id gnat_temp;
1076   tree gnu_result = alloc_stmt_list ();
1077
1078   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1079      annotating types.  */
1080   if (type_annotate_only
1081       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1082     return gnu_result;
1083
1084   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1085     {
1086     case Pragma_Inspection_Point:
1087       /* Do nothing at top level: all such variables are already viewable.  */
1088       if (global_bindings_p ())
1089         break;
1090
1091       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1092            Present (gnat_temp);
1093            gnat_temp = Next (gnat_temp))
1094         {
1095           Node_Id gnat_expr = Expression (gnat_temp);
1096           tree gnu_expr = gnat_to_gnu (gnat_expr);
1097           int use_address;
1098           enum machine_mode mode;
1099           tree asm_constraint = NULL_TREE;
1100 #ifdef ASM_COMMENT_START
1101           char *comment;
1102 #endif
1103
1104           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1105             gnu_expr = TREE_OPERAND (gnu_expr, 0);
1106
1107           /* Use the value only if it fits into a normal register,
1108              otherwise use the address.  */
1109           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1110           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1111                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1112                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1113
1114           if (use_address)
1115             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1116
1117 #ifdef ASM_COMMENT_START
1118           comment = concat (ASM_COMMENT_START,
1119                             " inspection point: ",
1120                             Get_Name_String (Chars (gnat_expr)),
1121                             use_address ? " address" : "",
1122                             " is in %0",
1123                             NULL);
1124           asm_constraint = build_string (strlen (comment), comment);
1125           free (comment);
1126 #endif
1127           gnu_expr = build5 (ASM_EXPR, void_type_node,
1128                              asm_constraint,
1129                              NULL_TREE,
1130                              tree_cons
1131                              (build_tree_list (NULL_TREE,
1132                                                build_string (1, "g")),
1133                               gnu_expr, NULL_TREE),
1134                              NULL_TREE, NULL_TREE);
1135           ASM_VOLATILE_P (gnu_expr) = 1;
1136           set_expr_location_from_node (gnu_expr, gnat_node);
1137           append_to_statement_list (gnu_expr, &gnu_result);
1138         }
1139       break;
1140
1141     case Pragma_Optimize:
1142       switch (Chars (Expression
1143                      (First (Pragma_Argument_Associations (gnat_node)))))
1144         {
1145         case Name_Time:  case Name_Space:
1146           if (!optimize)
1147             post_error ("insufficient -O value?", gnat_node);
1148           break;
1149
1150         case Name_Off:
1151           if (optimize)
1152             post_error ("must specify -O0?", gnat_node);
1153           break;
1154
1155         default:
1156           gcc_unreachable ();
1157         }
1158       break;
1159
1160     case Pragma_Reviewable:
1161       if (write_symbols == NO_DEBUG)
1162         post_error ("must specify -g?", gnat_node);
1163       break;
1164     }
1165
1166   return gnu_result;
1167 }
1168 \f
1169 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1170    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
1171    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
1172
1173 static tree
1174 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1175 {
1176   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1177   tree gnu_type = TREE_TYPE (gnu_prefix);
1178   tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1179   bool prefix_unused = false;
1180
1181   /* If the input is a NULL_EXPR, make a new one.  */
1182   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1183     {
1184       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1185       *gnu_result_type_p = gnu_result_type;
1186       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1187     }
1188
1189   switch (attribute)
1190     {
1191     case Attr_Pos:
1192     case Attr_Val:
1193       /* These are just conversions since representation clauses for
1194          enumeration types are handled in the front-end.  */
1195       {
1196         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1197         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1198         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1199         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1200                                          checkp, checkp, true, gnat_node);
1201       }
1202       break;
1203
1204     case Attr_Pred:
1205     case Attr_Succ:
1206       /* These just add or subtract the constant 1 since representation
1207          clauses for enumeration types are handled in the front-end.  */
1208       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1209       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1210
1211       if (Do_Range_Check (First (Expressions (gnat_node))))
1212         {
1213           gnu_expr = gnat_protect_expr (gnu_expr);
1214           gnu_expr
1215             = emit_check
1216               (build_binary_op (EQ_EXPR, boolean_type_node,
1217                                 gnu_expr,
1218                                 attribute == Attr_Pred
1219                                 ? TYPE_MIN_VALUE (gnu_result_type)
1220                                 : TYPE_MAX_VALUE (gnu_result_type)),
1221                gnu_expr, CE_Range_Check_Failed, gnat_node);
1222         }
1223
1224       gnu_result
1225         = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1226                            gnu_result_type, gnu_expr,
1227                            convert (gnu_result_type, integer_one_node));
1228       break;
1229
1230     case Attr_Address:
1231     case Attr_Unrestricted_Access:
1232       /* Conversions don't change addresses but can cause us to miss the
1233          COMPONENT_REF case below, so strip them off.  */
1234       gnu_prefix = remove_conversions (gnu_prefix,
1235                                        !Must_Be_Byte_Aligned (gnat_node));
1236
1237       /* If we are taking 'Address of an unconstrained object, this is the
1238          pointer to the underlying array.  */
1239       if (attribute == Attr_Address)
1240         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1241
1242       /* If we are building a static dispatch table, we have to honor
1243          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1244          with the C++ ABI.  We do it in the non-static case as well,
1245          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
1246       else if (TARGET_VTABLE_USES_DESCRIPTORS
1247                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1248         {
1249           tree gnu_field, gnu_list = NULL_TREE, t;
1250           /* Descriptors can only be built here for top-level functions.  */
1251           bool build_descriptor = (global_bindings_p () != 0);
1252           int i;
1253
1254           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1255
1256           /* If we're not going to build the descriptor, we have to retrieve
1257              the one which will be built by the linker (or by the compiler
1258              later if a static chain is requested).  */
1259           if (!build_descriptor)
1260             {
1261               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1262               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1263                                          gnu_result);
1264               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1265             }
1266
1267           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1268                i < TARGET_VTABLE_USES_DESCRIPTORS;
1269                gnu_field = TREE_CHAIN (gnu_field), i++)
1270             {
1271               if (build_descriptor)
1272                 {
1273                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1274                               build_int_cst (NULL_TREE, i));
1275                   TREE_CONSTANT (t) = 1;
1276                 }
1277               else
1278                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1279                             gnu_field, NULL_TREE);
1280
1281               gnu_list = tree_cons (gnu_field, t, gnu_list);
1282             }
1283
1284           gnu_result = gnat_build_constructor (gnu_result_type, gnu_list);
1285           break;
1286         }
1287
1288       /* ... fall through ... */
1289
1290     case Attr_Access:
1291     case Attr_Unchecked_Access:
1292     case Attr_Code_Address:
1293       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1294       gnu_result
1295         = build_unary_op (((attribute == Attr_Address
1296                             || attribute == Attr_Unrestricted_Access)
1297                            && !Must_Be_Byte_Aligned (gnat_node))
1298                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
1299                           gnu_result_type, gnu_prefix);
1300
1301       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1302          don't try to build a trampoline.  */
1303       if (attribute == Attr_Code_Address)
1304         {
1305           for (gnu_expr = gnu_result;
1306                CONVERT_EXPR_P (gnu_expr);
1307                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1308             TREE_CONSTANT (gnu_expr) = 1;
1309
1310           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1311             TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1312         }
1313
1314       /* For other address attributes applied to a nested function,
1315          find an inner ADDR_EXPR and annotate it so that we can issue
1316          a useful warning with -Wtrampolines.  */
1317       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1318         {
1319           for (gnu_expr = gnu_result;
1320                CONVERT_EXPR_P (gnu_expr);
1321                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1322             ;
1323
1324           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1325               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1326             {
1327               set_expr_location_from_node (gnu_expr, gnat_node);
1328
1329               /* Check that we're not violating the No_Implicit_Dynamic_Code
1330                  restriction.  Be conservative if we don't know anything
1331                  about the trampoline strategy for the target.  */
1332               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1333             }
1334         }
1335       break;
1336
1337     case Attr_Pool_Address:
1338       {
1339         tree gnu_obj_type;
1340         tree gnu_ptr = gnu_prefix;
1341
1342         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1343
1344         /* If this is an unconstrained array, we know the object has been
1345            allocated with the template in front of the object.  So compute
1346            the template address.  */
1347         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1348           gnu_ptr
1349             = convert (build_pointer_type
1350                        (TYPE_OBJECT_RECORD_TYPE
1351                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1352                        gnu_ptr);
1353
1354         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1355         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1356             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1357           {
1358             tree gnu_char_ptr_type
1359               = build_pointer_type (unsigned_char_type_node);
1360             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1361             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1362             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1363                                        gnu_ptr, gnu_pos);
1364           }
1365
1366         gnu_result = convert (gnu_result_type, gnu_ptr);
1367       }
1368       break;
1369
1370     case Attr_Size:
1371     case Attr_Object_Size:
1372     case Attr_Value_Size:
1373     case Attr_Max_Size_In_Storage_Elements:
1374       gnu_expr = gnu_prefix;
1375
1376       /* Remove NOPs and conversions between original and packable version
1377          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1378          to see if a COMPONENT_REF was involved.  */
1379       while (TREE_CODE (gnu_expr) == NOP_EXPR
1380              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1381                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1382                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1383                     == RECORD_TYPE
1384                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1385                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1386         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1387
1388       gnu_prefix = remove_conversions (gnu_prefix, true);
1389       prefix_unused = true;
1390       gnu_type = TREE_TYPE (gnu_prefix);
1391
1392       /* Replace an unconstrained array type with the type of the underlying
1393          array.  We can't do this with a call to maybe_unconstrained_array
1394          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1395          use the record type that will be used to allocate the object and its
1396          template.  */
1397       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1398         {
1399           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1400           if (attribute != Attr_Max_Size_In_Storage_Elements)
1401             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1402         }
1403
1404       /* If we're looking for the size of a field, return the field size.
1405          Otherwise, if the prefix is an object, or if we're looking for
1406          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1407          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1408       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1409         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1410       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1411                || attribute == Attr_Object_Size
1412                || attribute == Attr_Max_Size_In_Storage_Elements)
1413         {
1414           /* If the prefix is an object of a padded type, the GCC size isn't
1415              relevant to the programmer.  Normally what we want is the RM size,
1416              which was set from the specified size, but if it was not set, we
1417              want the size of the field.  Using the MAX of those two produces
1418              the right result in all cases.  Don't use the size of the field
1419              if it's self-referential, since that's never what's wanted.  */
1420           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1421               && TYPE_IS_PADDING_P (gnu_type)
1422               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1423             {
1424               gnu_result = rm_size (gnu_type);
1425               if (!CONTAINS_PLACEHOLDER_P
1426                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1427                 gnu_result
1428                   = size_binop (MAX_EXPR, gnu_result,
1429                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1430             }
1431           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1432             {
1433               Node_Id gnat_deref = Prefix (gnat_node);
1434               Node_Id gnat_actual_subtype
1435                 = Actual_Designated_Subtype (gnat_deref);
1436               tree gnu_ptr_type
1437                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1438
1439               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1440                   && Present (gnat_actual_subtype))
1441                 {
1442                   tree gnu_actual_obj_type
1443                     = gnat_to_gnu_type (gnat_actual_subtype);
1444                   gnu_type
1445                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1446                                                       gnu_actual_obj_type,
1447                                                       get_identifier ("SIZE"),
1448                                                       false);
1449                 }
1450
1451               gnu_result = TYPE_SIZE (gnu_type);
1452             }
1453           else
1454             gnu_result = TYPE_SIZE (gnu_type);
1455         }
1456       else
1457         gnu_result = rm_size (gnu_type);
1458
1459       /* Deal with a self-referential size by returning the maximum size for
1460          a type and by qualifying the size with the object otherwise.  */
1461       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1462         {
1463           if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1464             gnu_result = max_size (gnu_result, true);
1465           else
1466             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1467         }
1468
1469       /* If the type contains a template, subtract its size.  */
1470       if (TREE_CODE (gnu_type) == RECORD_TYPE
1471           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1472         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1473                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1474
1475       /* For 'Max_Size_In_Storage_Elements, adjust the unit.  */
1476       if (attribute == Attr_Max_Size_In_Storage_Elements)
1477         gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1478
1479       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1480       break;
1481
1482     case Attr_Alignment:
1483       {
1484         unsigned int align;
1485
1486         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1487             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1488           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1489
1490         gnu_type = TREE_TYPE (gnu_prefix);
1491         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1492         prefix_unused = true;
1493
1494         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1495           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1496         else
1497           {
1498             Node_Id gnat_prefix = Prefix (gnat_node);
1499             Entity_Id gnat_type = Etype (gnat_prefix);
1500             unsigned int double_align;
1501             bool is_capped_double, align_clause;
1502
1503             /* If the default alignment of "double" or larger scalar types is
1504                specifically capped and there is an alignment clause neither
1505                on the type nor on the prefix itself, return the cap.  */
1506             if ((double_align = double_float_alignment) > 0)
1507               is_capped_double
1508                 = is_double_float_or_array (gnat_type, &align_clause);
1509             else if ((double_align = double_scalar_alignment) > 0)
1510               is_capped_double
1511                 = is_double_scalar_or_array (gnat_type, &align_clause);
1512             else
1513               is_capped_double = align_clause = false;
1514
1515             if (is_capped_double
1516                 && Nkind (gnat_prefix) == N_Identifier
1517                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1518               align_clause = true;
1519
1520             if (is_capped_double && !align_clause)
1521               align = double_align;
1522             else
1523               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1524           }
1525
1526         gnu_result = size_int (align);
1527       }
1528       break;
1529
1530     case Attr_First:
1531     case Attr_Last:
1532     case Attr_Range_Length:
1533       prefix_unused = true;
1534
1535       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1536         {
1537           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1538
1539           if (attribute == Attr_First)
1540             gnu_result = TYPE_MIN_VALUE (gnu_type);
1541           else if (attribute == Attr_Last)
1542             gnu_result = TYPE_MAX_VALUE (gnu_type);
1543           else
1544             gnu_result
1545               = build_binary_op
1546                 (MAX_EXPR, get_base_type (gnu_result_type),
1547                  build_binary_op
1548                  (PLUS_EXPR, get_base_type (gnu_result_type),
1549                   build_binary_op (MINUS_EXPR,
1550                                    get_base_type (gnu_result_type),
1551                                    convert (gnu_result_type,
1552                                             TYPE_MAX_VALUE (gnu_type)),
1553                                    convert (gnu_result_type,
1554                                             TYPE_MIN_VALUE (gnu_type))),
1555                   convert (gnu_result_type, integer_one_node)),
1556                  convert (gnu_result_type, integer_zero_node));
1557
1558           break;
1559         }
1560
1561       /* ... fall through ... */
1562
1563     case Attr_Length:
1564       {
1565         int Dimension = (Present (Expressions (gnat_node))
1566                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1567                          : 1), i;
1568         struct parm_attr_d *pa = NULL;
1569         Entity_Id gnat_param = Empty;
1570
1571         /* Make sure any implicit dereference gets done.  */
1572         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1573         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1574         /* We treat unconstrained array In parameters specially.  */
1575         if (Nkind (Prefix (gnat_node)) == N_Identifier
1576             && !Is_Constrained (Etype (Prefix (gnat_node)))
1577             && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1578           gnat_param = Entity (Prefix (gnat_node));
1579         gnu_type = TREE_TYPE (gnu_prefix);
1580         prefix_unused = true;
1581         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1582
1583         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1584           {
1585             int ndim;
1586             tree gnu_type_temp;
1587
1588             for (ndim = 1, gnu_type_temp = gnu_type;
1589                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1590                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1591                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1592               ;
1593
1594             Dimension = ndim + 1 - Dimension;
1595           }
1596
1597         for (i = 1; i < Dimension; i++)
1598           gnu_type = TREE_TYPE (gnu_type);
1599
1600         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1601
1602         /* When not optimizing, look up the slot associated with the parameter
1603            and the dimension in the cache and create a new one on failure.  */
1604         if (!optimize && Present (gnat_param))
1605           {
1606             for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
1607               if (pa->id == gnat_param && pa->dim == Dimension)
1608                 break;
1609
1610             if (!pa)
1611               {
1612                 pa = GGC_CNEW (struct parm_attr_d);
1613                 pa->id = gnat_param;
1614                 pa->dim = Dimension;
1615                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1616               }
1617           }
1618
1619         /* Return the cached expression or build a new one.  */
1620         if (attribute == Attr_First)
1621           {
1622             if (pa && pa->first)
1623               {
1624                 gnu_result = pa->first;
1625                 break;
1626               }
1627
1628             gnu_result
1629               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1630           }
1631
1632         else if (attribute == Attr_Last)
1633           {
1634             if (pa && pa->last)
1635               {
1636                 gnu_result = pa->last;
1637                 break;
1638               }
1639
1640             gnu_result
1641               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1642           }
1643
1644         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1645           {
1646             if (pa && pa->length)
1647               {
1648                 gnu_result = pa->length;
1649                 break;
1650               }
1651             else
1652               {
1653                 /* We used to compute the length as max (hb - lb + 1, 0),
1654                    which could overflow for some cases of empty arrays, e.g.
1655                    when lb == index_type'first.  We now compute the length as
1656                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1657                    much rarer cases, for extremely large arrays we expect
1658                    never to encounter in practice.  In addition, the former
1659                    computation required the use of potentially constraining
1660                    signed arithmetic while the latter doesn't.  Note that
1661                    the comparison must be done in the original index type,
1662                    to avoid any overflow during the conversion.  */
1663                 tree comp_type = get_base_type (gnu_result_type);
1664                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1665                 tree lb = TYPE_MIN_VALUE (index_type);
1666                 tree hb = TYPE_MAX_VALUE (index_type);
1667                 gnu_result
1668                   = build_binary_op (PLUS_EXPR, comp_type,
1669                                      build_binary_op (MINUS_EXPR,
1670                                                       comp_type,
1671                                                       convert (comp_type, hb),
1672                                                       convert (comp_type, lb)),
1673                                      convert (comp_type, integer_one_node));
1674                 gnu_result
1675                   = build_cond_expr (comp_type,
1676                                      build_binary_op (GE_EXPR,
1677                                                       boolean_type_node,
1678                                                       hb, lb),
1679                                      gnu_result,
1680                                      convert (comp_type, integer_zero_node));
1681               }
1682           }
1683
1684         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1685            handling.  Note that these attributes could not have been used on
1686            an unconstrained array type.  */
1687         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1688
1689         /* Cache the expression we have just computed.  Since we want to do it
1690            at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1691            create the temporary.  */
1692         if (pa)
1693           {
1694             gnu_result
1695               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1696             TREE_SIDE_EFFECTS (gnu_result) = 1;
1697             if (attribute == Attr_First)
1698               pa->first = gnu_result;
1699             else if (attribute == Attr_Last)
1700               pa->last = gnu_result;
1701             else
1702               pa->length = gnu_result;
1703           }
1704
1705         /* Set the source location onto the predicate of the condition in the
1706            'Length case but do not do it if the expression is cached to avoid
1707            messing up the debug info.  */
1708         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1709                  && TREE_CODE (gnu_result) == COND_EXPR
1710                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1711           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1712                                        gnat_node);
1713
1714         break;
1715       }
1716
1717     case Attr_Bit_Position:
1718     case Attr_Position:
1719     case Attr_First_Bit:
1720     case Attr_Last_Bit:
1721     case Attr_Bit:
1722       {
1723         HOST_WIDE_INT bitsize;
1724         HOST_WIDE_INT bitpos;
1725         tree gnu_offset;
1726         tree gnu_field_bitpos;
1727         tree gnu_field_offset;
1728         tree gnu_inner;
1729         enum machine_mode mode;
1730         int unsignedp, volatilep;
1731
1732         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1733         gnu_prefix = remove_conversions (gnu_prefix, true);
1734         prefix_unused = true;
1735
1736         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1737            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1738         if (attribute == Attr_Bit
1739             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1740             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1741           {
1742             gnu_result = integer_zero_node;
1743             break;
1744           }
1745
1746         else
1747           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1748                       || (attribute == Attr_Bit_Position
1749                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1750
1751         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1752                              &mode, &unsignedp, &volatilep, false);
1753
1754         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1755           {
1756             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1757             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1758
1759             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1760                  TREE_CODE (gnu_inner) == COMPONENT_REF
1761                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1762                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1763               {
1764                 gnu_field_bitpos
1765                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1766                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1767                 gnu_field_offset
1768                   = size_binop (PLUS_EXPR, gnu_field_offset,
1769                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1770               }
1771           }
1772         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1773           {
1774             gnu_field_bitpos = bit_position (gnu_prefix);
1775             gnu_field_offset = byte_position (gnu_prefix);
1776           }
1777         else
1778           {
1779             gnu_field_bitpos = bitsize_zero_node;
1780             gnu_field_offset = size_zero_node;
1781           }
1782
1783         switch (attribute)
1784           {
1785           case Attr_Position:
1786             gnu_result = gnu_field_offset;
1787             break;
1788
1789           case Attr_First_Bit:
1790           case Attr_Bit:
1791             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1792             break;
1793
1794           case Attr_Last_Bit:
1795             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1796             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1797                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1798             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1799                                      bitsize_one_node);
1800             break;
1801
1802           case Attr_Bit_Position:
1803             gnu_result = gnu_field_bitpos;
1804             break;
1805                 }
1806
1807         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1808            handling.  */
1809         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1810         break;
1811       }
1812
1813     case Attr_Min:
1814     case Attr_Max:
1815       {
1816         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1817         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1818
1819         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1820         gnu_result = build_binary_op (attribute == Attr_Min
1821                                       ? MIN_EXPR : MAX_EXPR,
1822                                       gnu_result_type, gnu_lhs, gnu_rhs);
1823       }
1824       break;
1825
1826     case Attr_Passed_By_Reference:
1827       gnu_result = size_int (default_pass_by_ref (gnu_type)
1828                              || must_pass_by_ref (gnu_type));
1829       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1830       break;
1831
1832     case Attr_Component_Size:
1833       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1834           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1835         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1836
1837       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1838       gnu_type = TREE_TYPE (gnu_prefix);
1839
1840       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1841         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1842
1843       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1844              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1845         gnu_type = TREE_TYPE (gnu_type);
1846
1847       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1848
1849       /* Note this size cannot be self-referential.  */
1850       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1851       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1852       prefix_unused = true;
1853       break;
1854
1855     case Attr_Null_Parameter:
1856       /* This is just a zero cast to the pointer type for our prefix and
1857          dereferenced.  */
1858       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1859       gnu_result
1860         = build_unary_op (INDIRECT_REF, NULL_TREE,
1861                           convert (build_pointer_type (gnu_result_type),
1862                                    integer_zero_node));
1863       TREE_PRIVATE (gnu_result) = 1;
1864       break;
1865
1866     case Attr_Mechanism_Code:
1867       {
1868         int code;
1869         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1870
1871         prefix_unused = true;
1872         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1873         if (Present (Expressions (gnat_node)))
1874           {
1875             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1876
1877             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1878                  i--, gnat_obj = Next_Formal (gnat_obj))
1879               ;
1880           }
1881
1882         code = Mechanism (gnat_obj);
1883         if (code == Default)
1884           code = ((present_gnu_tree (gnat_obj)
1885                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1886                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1887                             == PARM_DECL)
1888                            && (DECL_BY_COMPONENT_PTR_P
1889                                (get_gnu_tree (gnat_obj))))))
1890                   ? By_Reference : By_Copy);
1891         gnu_result = convert (gnu_result_type, size_int (- code));
1892       }
1893       break;
1894
1895     default:
1896       /* Say we have an unimplemented attribute.  Then set the value to be
1897          returned to be a zero and hope that's something we can convert to
1898          the type of this attribute.  */
1899       post_error ("unimplemented attribute", gnat_node);
1900       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1901       gnu_result = integer_zero_node;
1902       break;
1903     }
1904
1905   /* If this is an attribute where the prefix was unused, force a use of it if
1906      it has a side-effect.  But don't do it if the prefix is just an entity
1907      name.  However, if an access check is needed, we must do it.  See second
1908      example in AARM 11.6(5.e).  */
1909   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1910       && !Is_Entity_Name (Prefix (gnat_node)))
1911     gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1912                               gnu_prefix, gnu_result);
1913
1914   *gnu_result_type_p = gnu_result_type;
1915   return gnu_result;
1916 }
1917 \f
1918 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1919    to a GCC tree, which is returned.  */
1920
1921 static tree
1922 Case_Statement_to_gnu (Node_Id gnat_node)
1923 {
1924   tree gnu_result;
1925   tree gnu_expr;
1926   Node_Id gnat_when;
1927
1928   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1929   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1930
1931   /*  The range of values in a case statement is determined by the rules in
1932       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1933       of the expression. One exception arises in the case of a simple name that
1934       is parenthesized. This still has the Etype of the name, but since it is
1935       not a name, para 7 does not apply, and we need to go to the base type.
1936       This is the only case where parenthesization affects the dynamic
1937       semantics (i.e. the range of possible values at runtime that is covered
1938       by the others alternative.
1939
1940       Another exception is if the subtype of the expression is non-static.  In
1941       that case, we also have to use the base type.  */
1942   if (Paren_Count (Expression (gnat_node)) != 0
1943       || !Is_OK_Static_Subtype (Underlying_Type
1944                                 (Etype (Expression (gnat_node)))))
1945     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1946
1947   /* We build a SWITCH_EXPR that contains the code with interspersed
1948      CASE_LABEL_EXPRs for each label.  */
1949
1950   push_stack (&gnu_switch_label_stack, NULL_TREE,
1951               create_artificial_label (input_location));
1952   start_stmt_group ();
1953   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1954        Present (gnat_when);
1955        gnat_when = Next_Non_Pragma (gnat_when))
1956     {
1957       bool choices_added_p = false;
1958       Node_Id gnat_choice;
1959
1960       /* First compile all the different case choices for the current WHEN
1961          alternative.  */
1962       for (gnat_choice = First (Discrete_Choices (gnat_when));
1963            Present (gnat_choice); gnat_choice = Next (gnat_choice))
1964         {
1965           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1966
1967           switch (Nkind (gnat_choice))
1968             {
1969             case N_Range:
1970               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1971               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1972               break;
1973
1974             case N_Subtype_Indication:
1975               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1976                                                 (Constraint (gnat_choice))));
1977               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1978                                                   (Constraint (gnat_choice))));
1979               break;
1980
1981             case N_Identifier:
1982             case N_Expanded_Name:
1983               /* This represents either a subtype range or a static value of
1984                  some kind; Ekind says which.  */
1985               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1986                 {
1987                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1988
1989                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1990                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1991                   break;
1992                 }
1993
1994               /* ... fall through ... */
1995
1996             case N_Character_Literal:
1997             case N_Integer_Literal:
1998               gnu_low = gnat_to_gnu (gnat_choice);
1999               break;
2000
2001             case N_Others_Choice:
2002               break;
2003
2004             default:
2005               gcc_unreachable ();
2006             }
2007
2008           /* If the case value is a subtype that raises Constraint_Error at
2009              run-time because of a wrong bound, then gnu_low or gnu_high is
2010              not translated into an INTEGER_CST.  In such a case, we need
2011              to ensure that the when statement is not added in the tree,
2012              otherwise it will crash the gimplifier.  */
2013           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2014               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2015             {
2016               add_stmt_with_node (build3
2017                                   (CASE_LABEL_EXPR, void_type_node,
2018                                    gnu_low, gnu_high,
2019                                    create_artificial_label (input_location)),
2020                                   gnat_choice);
2021               choices_added_p = true;
2022             }
2023         }
2024
2025       /* Push a binding level here in case variables are declared as we want
2026          them to be local to this set of statements instead of to the block
2027          containing the Case statement.  */
2028       if (choices_added_p)
2029         {
2030           add_stmt (build_stmt_group (Statements (gnat_when), true));
2031           add_stmt (build1 (GOTO_EXPR, void_type_node,
2032                             TREE_VALUE (gnu_switch_label_stack)));
2033         }
2034     }
2035
2036   /* Now emit a definition of the label all the cases branched to.  */
2037   add_stmt (build1 (LABEL_EXPR, void_type_node,
2038                     TREE_VALUE (gnu_switch_label_stack)));
2039   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2040                        end_stmt_group (), NULL_TREE);
2041   pop_stack (&gnu_switch_label_stack);
2042
2043   return gnu_result;
2044 }
2045 \f
2046 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2047    false, or the maximum value if MAX is true, of TYPE.  */
2048
2049 static bool
2050 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2051 {
2052   tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2053
2054   if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2055     return true;
2056
2057   if (TREE_CODE (val) == NOP_EXPR)
2058     val = (max
2059            ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2060            : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2061
2062   if (TREE_CODE (val) != INTEGER_CST)
2063     return true;
2064
2065   return tree_int_cst_equal (val, min_or_max_val) == 1;
2066 }
2067
2068 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2069    If REVERSE is true, minimum value is taken as maximum value.  */
2070
2071 static inline bool
2072 can_equal_min_val_p (tree val, tree type, bool reverse)
2073 {
2074   return can_equal_min_or_max_val_p (val, type, reverse);
2075 }
2076
2077 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2078    If REVERSE is true, maximum value is taken as minimum value.  */
2079
2080 static inline bool
2081 can_equal_max_val_p (tree val, tree type, bool reverse)
2082 {
2083   return can_equal_min_or_max_val_p (val, type, !reverse);
2084 }
2085
2086 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2087    to a GCC tree, which is returned.  */
2088
2089 static tree
2090 Loop_Statement_to_gnu (Node_Id gnat_node)
2091 {
2092   const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2093   tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2094                                NULL_TREE, NULL_TREE, NULL_TREE);
2095   tree gnu_loop_label = create_artificial_label (input_location);
2096   tree gnu_loop_var = NULL_TREE, gnu_cond_expr = NULL_TREE;
2097   tree gnu_result;
2098
2099   /* Set location information for statement and end label.  */
2100   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2101   Sloc_to_locus (Sloc (End_Label (gnat_node)),
2102                  &DECL_SOURCE_LOCATION (gnu_loop_label));
2103   LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2104
2105   /* Save the end label of this LOOP_STMT in a stack so that a corresponding
2106      N_Exit_Statement can find it.  */
2107   push_stack (&gnu_loop_label_stack, NULL_TREE, gnu_loop_label);
2108
2109   /* Set the condition under which the loop must keep going.
2110      For the case "LOOP .... END LOOP;" the condition is always true.  */
2111   if (No (gnat_iter_scheme))
2112     ;
2113
2114   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2115   else if (Present (Condition (gnat_iter_scheme)))
2116     LOOP_STMT_COND (gnu_loop_stmt)
2117       = gnat_to_gnu (Condition (gnat_iter_scheme));
2118
2119   /* Otherwise we have an iteration scheme and the condition is given by the
2120      bounds of the subtype of the iteration variable.  */
2121   else
2122     {
2123       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2124       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2125       Entity_Id gnat_type = Etype (gnat_loop_var);
2126       tree gnu_type = get_unpadded_type (gnat_type);
2127       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2128       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2129       tree gnu_base_type = get_base_type (gnu_type);
2130       tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2131       tree gnu_first, gnu_last;
2132       enum tree_code update_code, test_code, shift_code;
2133       bool reverse = Reverse_Present (gnat_loop_spec), fallback = false;
2134
2135       /* We must disable modulo reduction for the iteration variable, if any,
2136          in order for the loop comparison to be effective.  */
2137       if (reverse)
2138         {
2139           gnu_first = gnu_high;
2140           gnu_last = gnu_low;
2141           update_code = MINUS_NOMOD_EXPR;
2142           test_code = GE_EXPR;
2143           shift_code = PLUS_NOMOD_EXPR;
2144         }
2145       else
2146         {
2147           gnu_first = gnu_low;
2148           gnu_last = gnu_high;
2149           update_code = PLUS_NOMOD_EXPR;
2150           test_code = LE_EXPR;
2151           shift_code = MINUS_NOMOD_EXPR;
2152         }
2153
2154       /* We use two different strategies to translate the loop, depending on
2155          whether optimization is enabled.
2156
2157          If it is, we try to generate the canonical form of loop expected by
2158          the loop optimizer, which is the do-while form:
2159
2160              ENTRY_COND
2161            loop:
2162              TOP_UPDATE
2163              BODY
2164              BOTTOM_COND
2165              GOTO loop
2166
2167          This makes it possible to bypass loop header copying and to turn the
2168          BOTTOM_COND into an inequality test.  This should catch (almost) all
2169          loops with constant starting point.  If we cannot, we try to generate
2170          the default form, which is:
2171
2172            loop:
2173              TOP_COND
2174              BODY
2175              BOTTOM_UPDATE
2176              GOTO loop
2177
2178          It will be rotated during loop header copying and an entry test added
2179          to yield the do-while form.  This should catch (almost) all loops with
2180          constant ending point.  If we cannot, we generate the fallback form:
2181
2182              ENTRY_COND
2183            loop:
2184              BODY
2185              BOTTOM_COND
2186              BOTTOM_UPDATE
2187              GOTO loop
2188
2189          which works in all cases but for which loop header copying will copy
2190          the BOTTOM_COND, thus adding a third conditional branch.
2191
2192          If optimization is disabled, loop header copying doesn't come into
2193          play and we try to generate the loop forms with the less conditional
2194          branches directly.  First, the default form, it should catch (almost)
2195          all loops with constant ending point.  Then, if we cannot, we try to
2196          generate the shifted form:
2197
2198            loop:
2199              TOP_COND
2200              TOP_UPDATE
2201              BODY
2202              GOTO loop
2203
2204          which should catch loops with constant starting point.  Otherwise, if
2205          we cannot, we generate the fallback form.  */
2206
2207       if (optimize)
2208         {
2209           /* We can use the do-while form if GNU_FIRST-1 doesn't overflow.  */
2210           if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2211             {
2212               gnu_first = build_binary_op (shift_code, gnu_base_type,
2213                                            gnu_first, gnu_one_node);
2214               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2215               LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2216             }
2217
2218           /* Otherwise, we can use the default form if GNU_LAST+1 doesn't.  */
2219           else if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2220             ;
2221
2222           /* Otherwise, use the fallback form.  */
2223           else
2224             fallback = true;
2225         }
2226       else
2227         {
2228           /* We can use the default form if GNU_LAST+1 doesn't overflow.  */
2229           if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2230             ;
2231
2232           /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2233              GNU_LAST-1 does.  */
2234           else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2235                    && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2236             {
2237               gnu_first = build_binary_op (shift_code, gnu_base_type,
2238                                            gnu_first, gnu_one_node);
2239               gnu_last = build_binary_op (shift_code, gnu_base_type,
2240                                           gnu_last, gnu_one_node);
2241               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2242             }
2243
2244           /* Otherwise, use the fallback form.  */
2245           else
2246             fallback = true;
2247         }
2248
2249       if (fallback)
2250         LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2251
2252       /* If we use the BOTTOM_COND, we can turn the test into an inequality
2253          test but we have to add an ENTRY_COND to protect the empty loop.  */
2254       if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2255         {
2256           test_code = NE_EXPR;
2257           gnu_cond_expr
2258             = build3 (COND_EXPR, void_type_node,
2259                       build_binary_op (LE_EXPR, boolean_type_node,
2260                                        gnu_low, gnu_high),
2261                       NULL_TREE, alloc_stmt_list ());
2262           set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2263         }
2264
2265       /* Open a new nesting level that will surround the loop to declare the
2266          iteration variable.  */
2267       start_stmt_group ();
2268       gnat_pushlevel ();
2269
2270       /* Declare the iteration variable and set it to its initial value.  */
2271       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2272       if (DECL_BY_REF_P (gnu_loop_var))
2273         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2274
2275       /* Do all the arithmetics in the base type.  */
2276       gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2277
2278       /* Set either the top or bottom exit condition.  */
2279       LOOP_STMT_COND (gnu_loop_stmt)
2280         = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2281                            gnu_last);
2282
2283       /* Set either the top or bottom update statement and give it the source
2284          location of the iteration for better coverage info.  */
2285       LOOP_STMT_UPDATE (gnu_loop_stmt)
2286         = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2287                            build_binary_op (update_code, gnu_base_type,
2288                                             gnu_loop_var, gnu_one_node));
2289       set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
2290                                    gnat_iter_scheme);
2291     }
2292
2293   /* If the loop was named, have the name point to this loop.  In this case,
2294      the association is not a DECL node, but the end label of the loop.  */
2295   if (Present (Identifier (gnat_node)))
2296     save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2297
2298   /* Make the loop body into its own block, so any allocated storage will be
2299      released every iteration.  This is needed for stack allocation.  */
2300   LOOP_STMT_BODY (gnu_loop_stmt)
2301     = build_stmt_group (Statements (gnat_node), true);
2302   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2303
2304   /* If we declared a variable, then we are in a statement group for that
2305      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
2306   if (gnu_loop_var)
2307     {
2308       add_stmt (gnu_loop_stmt);
2309       gnat_poplevel ();
2310       gnu_loop_stmt = end_stmt_group ();
2311     }
2312
2313   /* If we have an outer COND_EXPR, that's our result and this loop is its
2314      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2315   if (gnu_cond_expr)
2316     {
2317       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2318       gnu_result = gnu_cond_expr;
2319       recalculate_side_effects (gnu_cond_expr);
2320     }
2321   else
2322     gnu_result = gnu_loop_stmt;
2323
2324   pop_stack (&gnu_loop_label_stack);
2325
2326   return gnu_result;
2327 }
2328 \f
2329 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2330    handler for the current function.  */
2331
2332 /* This is implemented by issuing a call to the appropriate VMS specific
2333    builtin.  To avoid having VMS specific sections in the global gigi decls
2334    array, we maintain the decls of interest here.  We can't declare them
2335    inside the function because we must mark them never to be GC'd, which we
2336    can only do at the global level.  */
2337
2338 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2339 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2340
2341 static void
2342 establish_gnat_vms_condition_handler (void)
2343 {
2344   tree establish_stmt;
2345
2346   /* Elaborate the required decls on the first call.  Check on the decl for
2347      the gnat condition handler to decide, as this is one we create so we are
2348      sure that it will be non null on subsequent calls.  The builtin decl is
2349      looked up so remains null on targets where it is not implemented yet.  */
2350   if (gnat_vms_condition_handler_decl == NULL_TREE)
2351     {
2352       vms_builtin_establish_handler_decl
2353         = builtin_decl_for
2354           (get_identifier ("__builtin_establish_vms_condition_handler"));
2355
2356       gnat_vms_condition_handler_decl
2357         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2358                                NULL_TREE,
2359                                build_function_type_list (boolean_type_node,
2360                                                          ptr_void_type_node,
2361                                                          ptr_void_type_node,
2362                                                          NULL_TREE),
2363                                NULL_TREE, 0, 1, 1, 0, Empty);
2364
2365       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2366       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2367     }
2368
2369   /* Do nothing if the establish builtin is not available, which might happen
2370      on targets where the facility is not implemented.  */
2371   if (vms_builtin_establish_handler_decl == NULL_TREE)
2372     return;
2373
2374   establish_stmt
2375     = build_call_1_expr (vms_builtin_establish_handler_decl,
2376                          build_unary_op
2377                          (ADDR_EXPR, NULL_TREE,
2378                           gnat_vms_condition_handler_decl));
2379
2380   add_stmt (establish_stmt);
2381 }
2382 \f
2383 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
2384    don't return anything.  */
2385
2386 static void
2387 Subprogram_Body_to_gnu (Node_Id gnat_node)
2388 {
2389   /* Defining identifier of a parameter to the subprogram.  */
2390   Entity_Id gnat_param;
2391   /* The defining identifier for the subprogram body. Note that if a
2392      specification has appeared before for this body, then the identifier
2393      occurring in that specification will also be a defining identifier and all
2394      the calls to this subprogram will point to that specification.  */
2395   Entity_Id gnat_subprog_id
2396     = (Present (Corresponding_Spec (gnat_node))
2397        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2398   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
2399   tree gnu_subprog_decl;
2400   /* Its RESULT_DECL node.  */
2401   tree gnu_result_decl;
2402   /* The FUNCTION_TYPE node corresponding to the subprogram spec.  */
2403   tree gnu_subprog_type;
2404   tree gnu_cico_list;
2405   tree gnu_result;
2406   VEC(parm_attr,gc) *cache;
2407
2408   /* If this is a generic object or if it has been eliminated,
2409      ignore it.  */
2410   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2411       || Ekind (gnat_subprog_id) == E_Generic_Function
2412       || Is_Eliminated (gnat_subprog_id))
2413     return;
2414
2415   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
2416      the already-elaborated tree node.  However, if this subprogram had its
2417      elaboration deferred, we will already have made a tree node for it.  So
2418      treat it as not being defined in that case.  Such a subprogram cannot
2419      have an address clause or a freeze node, so this test is safe, though it
2420      does disable some otherwise-useful error checking.  */
2421   gnu_subprog_decl
2422     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2423                           Acts_As_Spec (gnat_node)
2424                           && !present_gnu_tree (gnat_subprog_id));
2425   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
2426   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2427
2428   /* If the function returns by invisible reference, make it explicit in the
2429      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.  */
2430   if (TREE_ADDRESSABLE (gnu_subprog_type))
2431     {
2432       TREE_TYPE (gnu_result_decl)
2433         = build_reference_type (TREE_TYPE (gnu_result_decl));
2434       relayout_decl (gnu_result_decl);
2435     }
2436
2437   /* Propagate the debug mode.  */
2438   if (!Needs_Debug_Info (gnat_subprog_id))
2439     DECL_IGNORED_P (gnu_subprog_decl) = 1;
2440
2441   /* Set the line number in the decl to correspond to that of the body so that
2442      the line number notes are written correctly.  */
2443   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
2444
2445   /* Initialize the information structure for the function.  */
2446   allocate_struct_function (gnu_subprog_decl, false);
2447   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
2448     = GGC_CNEW (struct language_function);
2449   set_cfun (NULL);
2450
2451   begin_subprog_body (gnu_subprog_decl);
2452
2453   /* If there are Out parameters, we need to ensure that the return statement
2454      properly copies them out.  We do this by making a new block and converting
2455      any inner return into a goto to a label at the end of the block.  */
2456   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2457   push_stack (&gnu_return_label_stack, NULL_TREE,
2458               gnu_cico_list ? create_artificial_label (input_location)
2459               : NULL_TREE);
2460
2461   /* Get a tree corresponding to the code for the subprogram.  */
2462   start_stmt_group ();
2463   gnat_pushlevel ();
2464
2465   /* See if there are any parameters for which we don't yet have GCC entities.
2466      These must be for Out parameters for which we will be making VAR_DECL
2467      nodes here.  Fill them in to TYPE_CI_CO_LIST, which must contain the empty
2468      entry as well.  We can match up the entries because TYPE_CI_CO_LIST is in
2469      the order of the parameters.  */
2470   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2471        Present (gnat_param);
2472        gnat_param = Next_Formal_With_Extras (gnat_param))
2473     if (!present_gnu_tree (gnat_param))
2474       {
2475         /* Skip any entries that have been already filled in; they must
2476            correspond to In Out parameters.  */
2477         for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
2478              gnu_cico_list = TREE_CHAIN (gnu_cico_list))
2479           ;
2480
2481         /* Do any needed references for padded types.  */
2482         TREE_VALUE (gnu_cico_list)
2483           = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
2484                      gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2485       }
2486
2487   /* On VMS, establish our condition handler to possibly turn a condition into
2488      the corresponding exception if the subprogram has a foreign convention or
2489      is exported.
2490
2491      To ensure proper execution of local finalizations on condition instances,
2492      we must turn a condition into the corresponding exception even if there
2493      is no applicable Ada handler, and need at least one condition handler per
2494      possible call chain involving GNAT code.  OTOH, establishing the handler
2495      has a cost so we want to minimize the number of subprograms into which
2496      this happens.  The foreign or exported condition is expected to satisfy
2497      all the constraints.  */
2498   if (TARGET_ABI_OPEN_VMS
2499       && (Has_Foreign_Convention (gnat_subprog_id)
2500           || Is_Exported (gnat_subprog_id)))
2501     establish_gnat_vms_condition_handler ();
2502
2503   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
2504
2505   /* Generate the code of the subprogram itself.  A return statement will be
2506      present and any Out parameters will be handled there.  */
2507   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
2508   gnat_poplevel ();
2509   gnu_result = end_stmt_group ();
2510
2511   /* If we populated the parameter attributes cache, we need to make sure
2512      that the cached expressions are evaluated on all possible paths.  */
2513   cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
2514   if (cache)
2515     {
2516       struct parm_attr_d *pa;
2517       int i;
2518
2519       start_stmt_group ();
2520
2521       for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
2522         {
2523           if (pa->first)
2524             add_stmt_with_node (pa->first, gnat_node);
2525           if (pa->last)
2526             add_stmt_with_node (pa->last, gnat_node);
2527           if (pa->length)
2528             add_stmt_with_node (pa->length, gnat_node);
2529         }
2530
2531       add_stmt (gnu_result);
2532       gnu_result = end_stmt_group ();
2533     }
2534
2535     /* If we are dealing with a return from an Ada procedure with parameters
2536        passed by copy-in/copy-out, we need to return a record containing the
2537        final values of these parameters.  If the list contains only one entry,
2538        return just that entry though.
2539
2540        For a full description of the copy-in/copy-out parameter mechanism, see
2541        the part of the gnat_to_gnu_entity routine dealing with the translation
2542        of subprograms.
2543
2544        We need to make a block that contains the definition of that label and
2545        the copying of the return value.  It first contains the function, then
2546        the label and copy statement.  */
2547   if (TREE_VALUE (gnu_return_label_stack))
2548     {
2549       tree gnu_retval;
2550
2551       start_stmt_group ();
2552       gnat_pushlevel ();
2553       add_stmt (gnu_result);
2554       add_stmt (build1 (LABEL_EXPR, void_type_node,
2555                         TREE_VALUE (gnu_return_label_stack)));
2556
2557       gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2558       if (list_length (gnu_cico_list) == 1)
2559         gnu_retval = TREE_VALUE (gnu_cico_list);
2560       else
2561         gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2562                                              gnu_cico_list);
2563
2564       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
2565                           End_Label (Handled_Statement_Sequence (gnat_node)));
2566       gnat_poplevel ();
2567       gnu_result = end_stmt_group ();
2568     }
2569
2570   pop_stack (&gnu_return_label_stack);
2571
2572   /* Set the end location.  */
2573   Sloc_to_locus
2574     ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
2575       ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
2576       : Sloc (gnat_node)),
2577      &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
2578
2579   end_subprog_body (gnu_result);
2580
2581   /* Finally annotate the parameters and disconnect the trees for parameters
2582      that we have turned into variables since they are now unusable.  */
2583   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2584        Present (gnat_param);
2585        gnat_param = Next_Formal_With_Extras (gnat_param))
2586     {
2587       tree gnu_param = get_gnu_tree (gnat_param);
2588       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
2589                        DECL_BY_REF_P (gnu_param));
2590       if (TREE_CODE (gnu_param) == VAR_DECL)
2591         save_gnu_tree (gnat_param, NULL_TREE, false);
2592     }
2593
2594   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2595     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2596
2597   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2598 }
2599 \f
2600 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2601    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2602    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2603    If GNU_TARGET is non-null, this must be a function call on the RHS of a
2604    N_Assignment_Statement and the result is to be placed into that object.  */
2605
2606 static tree
2607 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2608 {
2609   /* The GCC node corresponding to the GNAT subprogram name.  This can either
2610      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2611      or an indirect reference expression (an INDIRECT_REF node) pointing to a
2612      subprogram.  */
2613   tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
2614   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2615   tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
2616   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
2617   Entity_Id gnat_formal;
2618   Node_Id gnat_actual;
2619   VEC(tree,gc) *gnu_actual_vec = NULL;
2620   tree gnu_name_list = NULL_TREE;
2621   tree gnu_before_list = NULL_TREE;
2622   tree gnu_after_list = NULL_TREE;
2623   tree gnu_call;
2624   bool went_into_elab_proc = false;
2625
2626   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2627
2628   /* If we are calling a stubbed function, raise Program_Error, but Elaborate
2629      all our args first.  */
2630   if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
2631     {
2632       tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
2633                                          gnat_node, N_Raise_Program_Error);
2634
2635       for (gnat_actual = First_Actual (gnat_node);
2636            Present (gnat_actual);
2637            gnat_actual = Next_Actual (gnat_actual))
2638         add_stmt (gnat_to_gnu (gnat_actual));
2639
2640       if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
2641         {
2642           *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
2643           return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr);
2644         }
2645
2646       return call_expr;
2647     }
2648
2649   /* The only way we can be making a call via an access type is if Name is an
2650      explicit dereference.  In that case, get the list of formal args from the
2651      type the access type is pointing to.  Otherwise, get the formals from the
2652      entity being called.  */
2653   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2654     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2655   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2656     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2657     gnat_formal = Empty;
2658   else
2659     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2660
2661   /* If we are translating a statement, open a new nesting level that will
2662      surround it to declare the temporaries created for the call.  */
2663   if (Nkind (gnat_node) == N_Procedure_Call_Statement || gnu_target)
2664     {
2665       start_stmt_group ();
2666       gnat_pushlevel ();
2667     }
2668
2669   /* The lifetime of the temporaries created for the call ends with the call
2670      so we can give them the scope of the elaboration routine at top level.  */
2671   else if (!current_function_decl)
2672     {
2673       current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
2674       went_into_elab_proc = true;
2675     }
2676
2677   /* Create the list of the actual parameters as GCC expects it, namely a
2678      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
2679      is an expression and the TREE_PURPOSE field is null.  But skip Out
2680      parameters not passed by reference and that need not be copied in.  */
2681   for (gnat_actual = First_Actual (gnat_node);
2682        Present (gnat_actual);
2683        gnat_formal = Next_Formal_With_Extras (gnat_formal),
2684        gnat_actual = Next_Actual (gnat_actual))
2685     {
2686       tree gnu_formal = present_gnu_tree (gnat_formal)
2687                         ? get_gnu_tree (gnat_formal) : NULL_TREE;
2688       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2689       /* In the Out or In Out case, we must suppress conversions that yield
2690          an lvalue but can nevertheless cause the creation of a temporary,
2691          because we need the real object in this case, either to pass its
2692          address if it's passed by reference or as target of the back copy
2693          done after the call if it uses the copy-in copy-out mechanism.
2694          We do it in the In case too, except for an unchecked conversion
2695          because it alone can cause the actual to be misaligned and the
2696          addressability test is applied to the real object.  */
2697       bool suppress_type_conversion
2698         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2699             && Ekind (gnat_formal) != E_In_Parameter)
2700            || (Nkind (gnat_actual) == N_Type_Conversion
2701                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2702       Node_Id gnat_name = suppress_type_conversion
2703                           ? Expression (gnat_actual) : gnat_actual;
2704       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2705       tree gnu_actual;
2706
2707       /* If it's possible we may need to use this expression twice, make sure
2708          that any side-effects are handled via SAVE_EXPRs; likewise if we need
2709          to force side-effects before the call.
2710          ??? This is more conservative than we need since we don't need to do
2711          this for pass-by-ref with no conversion.  */
2712       if (Ekind (gnat_formal) != E_In_Parameter)
2713         gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
2714
2715       /* If we are passing a non-addressable parameter by reference, pass the
2716          address of a copy.  In the Out or In Out case, set up to copy back
2717          out after the call.  */
2718       if (gnu_formal
2719           && (DECL_BY_REF_P (gnu_formal)
2720               || (TREE_CODE (gnu_formal) == PARM_DECL
2721                   && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2722                       || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2723           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2724           && !addressable_p (gnu_name, gnu_name_type))
2725         {
2726           tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
2727
2728           /* Do not issue warnings for CONSTRUCTORs since this is not a copy
2729              but sort of an instantiation for them.  */
2730           if (TREE_CODE (gnu_name) == CONSTRUCTOR)
2731             ;
2732
2733           /* If the type is passed by reference, a copy is not allowed.  */
2734           else if (TREE_ADDRESSABLE (gnu_formal_type))
2735             post_error ("misaligned actual cannot be passed by reference",
2736                         gnat_actual);
2737
2738           /* For users of Starlet we issue a warning because the interface
2739              apparently assumes that by-ref parameters outlive the procedure
2740              invocation.  The code still will not work as intended, but we
2741              cannot do much better since low-level parts of the back-end
2742              would allocate temporaries at will because of the misalignment
2743              if we did not do so here.  */
2744           else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2745             {
2746               post_error
2747                 ("?possible violation of implicit assumption", gnat_actual);
2748               post_error_ne
2749                 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
2750                  Entity (Name (gnat_node)));
2751               post_error_ne ("?because of misalignment of &", gnat_actual,
2752                              gnat_formal);
2753             }
2754
2755           /* If the actual type of the object is already the nominal type,
2756              we have nothing to do, except if the size is self-referential
2757              in which case we'll remove the unpadding below.  */
2758           if (TREE_TYPE (gnu_name) == gnu_name_type
2759               && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
2760             ;
2761
2762           /* Otherwise remove the unpadding from all the objects.  */
2763           else if (TREE_CODE (gnu_name) == COMPONENT_REF
2764                    && TYPE_IS_PADDING_P
2765                       (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
2766             gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
2767
2768           /* Otherwise convert to the nominal type of the object if needed.
2769              There are several cases in which we need to make the temporary
2770              using this type instead of the actual type of the object when
2771              they are distinct, because the expectations of the callee would
2772              otherwise not be met:
2773                - if it's a justified modular type,
2774                - if the actual type is a smaller form of it,
2775                - if it's a smaller form of the actual type.  */
2776           else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
2777                     && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
2778                         || smaller_form_type_p (TREE_TYPE (gnu_name),
2779                                                 gnu_name_type)))
2780                    || (INTEGRAL_TYPE_P (gnu_name_type)
2781                        && smaller_form_type_p (gnu_name_type,
2782                                                TREE_TYPE (gnu_name))))
2783             gnu_name = convert (gnu_name_type, gnu_name);
2784
2785           /* Create an explicit temporary holding the copy.  This ensures that
2786              its lifetime is as narrow as possible around a statement.  */
2787           gnu_temp = create_var_decl (create_tmp_var_name ("A"), NULL_TREE,
2788                                       TREE_TYPE (gnu_name), NULL_TREE, false,
2789                                       false, false, false, NULL, Empty);
2790           DECL_ARTIFICIAL (gnu_temp) = 1;
2791           DECL_IGNORED_P (gnu_temp) = 1;
2792
2793           /* But initialize it on the fly like for an implicit temporary as
2794              we aren't necessarily dealing with a statement.  */
2795           gnu_stmt
2796             = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_name);
2797           set_expr_location_from_node (gnu_stmt, gnat_actual);
2798
2799           /* From now on, the real object is the temporary.  */
2800           gnu_name = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_name), gnu_stmt,
2801                              gnu_temp);
2802
2803           /* Set up to move the copy back to the original if needed.  */
2804           if (Ekind (gnat_formal) != E_In_Parameter)
2805             {
2806               gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
2807                                           gnu_temp);
2808               set_expr_location_from_node (gnu_stmt, gnat_node);
2809               append_to_statement_list (gnu_stmt, &gnu_after_list);
2810             }
2811         }
2812
2813       /* Start from the real object and build the actual.  */
2814       gnu_actual = gnu_name;
2815
2816       /* If this was a procedure call, we may not have removed any padding.
2817          So do it here for the part we will use as an input, if any.  */
2818       if (Ekind (gnat_formal) != E_Out_Parameter
2819           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2820         gnu_actual
2821           = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
2822
2823       /* Put back the conversion we suppressed above in the computation of the
2824          real object.  And even if we didn't suppress any conversion there, we
2825          may have suppressed a conversion to the Etype of the actual earlier,
2826          since the parent is a procedure call, so put it back here.  */
2827       if (suppress_type_conversion
2828           && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2829         gnu_actual
2830           = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2831                                gnu_actual, No_Truncation (gnat_actual));
2832       else
2833         gnu_actual
2834           = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
2835
2836       /* Make sure that the actual is in range of the formal's type.  */
2837       if (Ekind (gnat_formal) != E_Out_Parameter
2838           && Do_Range_Check (gnat_actual))
2839         gnu_actual
2840           = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
2841
2842       /* Unless this is an In parameter, we must remove any justified modular
2843          building from GNU_NAME to get an lvalue.  */
2844       if (Ekind (gnat_formal) != E_In_Parameter
2845           && TREE_CODE (gnu_name) == CONSTRUCTOR
2846           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2847           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2848         gnu_name
2849           = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
2850
2851       /* If we have not saved a GCC object for the formal, it means it is an
2852          Out parameter not passed by reference and that need not be copied in.
2853          Otherwise, first see if the parameter is passed by reference.  */
2854       if (gnu_formal
2855           && TREE_CODE (gnu_formal) == PARM_DECL
2856           && DECL_BY_REF_P (gnu_formal))
2857         {
2858           if (Ekind (gnat_formal) != E_In_Parameter)
2859             {
2860               /* In Out or Out parameters passed by reference don't use the
2861                  copy-in copy-out mechanism so the address of the real object
2862                  must be passed to the function.  */
2863               gnu_actual = gnu_name;
2864
2865               /* If we have a padded type, be sure we've removed padding.  */
2866               if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2867                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2868                                       gnu_actual);
2869
2870               /* If we have the constructed subtype of an aliased object
2871                  with an unconstrained nominal subtype, the type of the
2872                  actual includes the template, although it is formally
2873                  constrained.  So we need to convert it back to the real
2874                  constructed subtype to retrieve the constrained part
2875                  and takes its address.  */
2876               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2877                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
2878                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
2879                   && Is_Array_Type (Etype (gnat_actual)))
2880                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2881                                       gnu_actual);
2882             }
2883
2884           /* There is no need to convert the actual to the formal's type before
2885              taking its address.  The only exception is for unconstrained array
2886              types because of the way we build fat pointers.  */
2887           else if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
2888             gnu_actual = convert (gnu_formal_type, gnu_actual);
2889
2890           /* The symmetry of the paths to the type of an entity is broken here
2891              since arguments don't know that they will be passed by ref.  */
2892           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2893           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2894         }
2895       else if (gnu_formal
2896                && TREE_CODE (gnu_formal) == PARM_DECL
2897                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
2898         {
2899           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2900           gnu_actual = maybe_implicit_deref (gnu_actual);
2901           gnu_actual = maybe_unconstrained_array (gnu_actual);
2902
2903           if (TYPE_IS_PADDING_P (gnu_formal_type))
2904             {
2905               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2906               gnu_actual = convert (gnu_formal_type, gnu_actual);
2907             }
2908
2909           /* Take the address of the object and convert to the proper pointer
2910              type.  We'd like to actually compute the address of the beginning
2911              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2912              possibility that the ARRAY_REF might return a constant and we'd be
2913              getting the wrong address.  Neither approach is exactly correct,
2914              but this is the most likely to work in all cases.  */
2915           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2916         }
2917       else if (gnu_formal
2918                && TREE_CODE (gnu_formal) == PARM_DECL
2919                && DECL_BY_DESCRIPTOR_P (gnu_formal))
2920         {
2921           gnu_actual = convert (gnu_formal_type, gnu_actual);
2922
2923           /* If this is 'Null_Parameter, pass a zero descriptor.  */
2924           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2925                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2926               && TREE_PRIVATE (gnu_actual))
2927             gnu_actual
2928               = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
2929           else
2930             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
2931                                          fill_vms_descriptor (gnu_actual,
2932                                                               gnat_formal,
2933                                                               gnat_actual));
2934         }
2935       else
2936         {
2937           tree gnu_size;
2938
2939           if (Ekind (gnat_formal) != E_In_Parameter)
2940             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
2941
2942           if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
2943             {
2944               /* Make sure side-effects are evaluated before the call.  */
2945               if (TREE_SIDE_EFFECTS (gnu_name))
2946                 append_to_statement_list (gnu_name, &gnu_before_list);
2947               continue;
2948             }
2949
2950           gnu_actual = convert (gnu_formal_type, gnu_actual);
2951
2952           /* If this is 'Null_Parameter, pass a zero even though we are
2953              dereferencing it.  */
2954           if (TREE_CODE (gnu_actual) == INDIRECT_REF
2955               && TREE_PRIVATE (gnu_actual)
2956               && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
2957               && TREE_CODE (gnu_size) == INTEGER_CST
2958               && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
2959             gnu_actual
2960               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
2961                                    convert (gnat_type_for_size
2962                                             (TREE_INT_CST_LOW (gnu_size), 1),
2963                                             integer_zero_node),
2964                                    false);
2965           else
2966             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
2967         }
2968
2969       VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual);
2970     }
2971
2972   gnu_call = build_call_list (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr,
2973                               nreverse (gnu_actual_list));
2974   set_expr_location_from_node (gnu_call, gnat_node);
2975
2976   /* If it's a function call, the result is the call expression unless a target
2977      is specified, in which case we copy the result into the target and return
2978      the assignment statement.  */
2979   if (Nkind (gnat_node) == N_Function_Call)
2980     {
2981       tree gnu_result = gnu_call;
2982
2983       /* If the function returns an unconstrained array or by direct reference,
2984          we have to dereference the pointer.  */
2985       if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
2986           || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
2987         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2988
2989       if (gnu_target)
2990         {
2991           Node_Id gnat_parent = Parent (gnat_node);
2992           enum tree_code op_code;
2993
2994           /* If range check is needed, emit code to generate it.  */
2995           if (Do_Range_Check (gnat_node))
2996             gnu_result
2997               = emit_range_check (gnu_result, Etype (Name (gnat_parent)),
2998                                   gnat_parent);
2999
3000           /* ??? If the return type has non-constant size, then force the
3001              return slot optimization as we would not be able to generate
3002              a temporary.  That's what has been done historically.  */
3003           if (TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_subprog_type))))
3004             op_code = MODIFY_EXPR;
3005           else
3006             op_code = INIT_EXPR;
3007
3008           gnu_result
3009             = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result);
3010           add_stmt_with_node (gnu_result, gnat_parent);
3011           gnat_poplevel ();
3012           gnu_result = end_stmt_group ();
3013         }
3014       else
3015         {
3016           if (went_into_elab_proc)
3017             current_function_decl = NULL_TREE;
3018           *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
3019         }
3020
3021       return gnu_result;
3022     }
3023
3024   /* If this is the case where the GNAT tree contains a procedure call but the
3025      Ada procedure has copy-in/copy-out parameters, then the special parameter
3026      passing mechanism must be used.  */
3027   if (TYPE_CI_CO_LIST (gnu_subprog_type))
3028     {
3029       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
3030          copy-out parameters.  */
3031       tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3032       const int length = list_length (gnu_cico_list);
3033
3034       if (length > 1)
3035         {
3036           tree gnu_temp, gnu_stmt;
3037
3038           /* The call sequence must contain one and only one call, even though
3039              the function is pure.  Save the result into a temporary.  */
3040           gnu_temp = create_var_decl (create_tmp_var_name ("R"), NULL_TREE,
3041                                       TREE_TYPE (gnu_call), NULL_TREE, false,
3042                                       false, false, false, NULL, Empty);
3043           DECL_ARTIFICIAL (gnu_temp) = 1;
3044           DECL_IGNORED_P (gnu_temp) = 1;
3045
3046           gnu_stmt
3047             = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_call);
3048           set_expr_location_from_node (gnu_stmt, gnat_node);
3049
3050           /* Add the call statement to the list and start from its result.  */
3051           append_to_statement_list (gnu_stmt, &gnu_before_list);
3052           gnu_call = gnu_temp;
3053
3054           gnu_name_list = nreverse (gnu_name_list);
3055         }
3056
3057       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3058         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
3059       else
3060         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
3061
3062       for (gnat_actual = First_Actual (gnat_node);
3063            Present (gnat_actual);
3064            gnat_formal = Next_Formal_With_Extras (gnat_formal),
3065            gnat_actual = Next_Actual (gnat_actual))
3066         /* If we are dealing with a copy in copy out parameter, we must
3067            retrieve its value from the record returned in the call.  */
3068         if (!(present_gnu_tree (gnat_formal)
3069               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3070               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
3071                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3072                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
3073                            || (DECL_BY_DESCRIPTOR_P
3074                                (get_gnu_tree (gnat_formal))))))))
3075             && Ekind (gnat_formal) != E_In_Parameter)
3076           {
3077             /* Get the value to assign to this Out or In Out parameter.  It is
3078                either the result of the function if there is only a single such
3079                parameter or the appropriate field from the record returned.  */
3080             tree gnu_result
3081               = length == 1
3082                 ? gnu_call
3083                 : build_component_ref (gnu_call, NULL_TREE,
3084                                        TREE_PURPOSE (gnu_cico_list), false);
3085
3086             /* If the actual is a conversion, get the inner expression, which
3087                will be the real destination, and convert the result to the
3088                type of the actual parameter.  */
3089             tree gnu_actual
3090               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3091
3092             /* If the result is a padded type, remove the padding.  */
3093             if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3094               gnu_result
3095                 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
3096                            gnu_result);
3097
3098             /* If the actual is a type conversion, the real target object is
3099                denoted by the inner Expression and we need to convert the
3100                result to the associated type.
3101                We also need to convert our gnu assignment target to this type
3102                if the corresponding GNU_NAME was constructed from the GNAT
3103                conversion node and not from the inner Expression.  */
3104             if (Nkind (gnat_actual) == N_Type_Conversion)
3105               {
3106                 gnu_result
3107                   = convert_with_check
3108                     (Etype (Expression (gnat_actual)), gnu_result,
3109                      Do_Overflow_Check (gnat_actual),
3110                      Do_Range_Check (Expression (gnat_actual)),
3111                      Float_Truncate (gnat_actual), gnat_actual);
3112
3113                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
3114                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
3115               }
3116
3117             /* Unchecked conversions as actuals for Out parameters are not
3118                allowed in user code because they are not variables, but do
3119                occur in front-end expansions.  The associated GNU_NAME is
3120                always obtained from the inner expression in such cases.  */
3121             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
3122               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
3123                                               gnu_result,
3124                                               No_Truncation (gnat_actual));
3125             else
3126               {
3127                 if (Do_Range_Check (gnat_actual))
3128                   gnu_result
3129                     = emit_range_check (gnu_result, Etype (gnat_actual),
3130                                         gnat_actual);
3131
3132                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
3133                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
3134                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
3135               }
3136
3137             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3138                                           gnu_actual, gnu_result);
3139             set_expr_location_from_node (gnu_result, gnat_node);
3140             append_to_statement_list (gnu_result, &gnu_before_list);
3141             gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3142             gnu_name_list = TREE_CHAIN (gnu_name_list);
3143           }
3144     }
3145   else
3146     append_to_statement_list (gnu_call, &gnu_before_list);
3147
3148   append_to_statement_list (gnu_after_list, &gnu_before_list);
3149
3150   add_stmt (gnu_before_list);
3151   gnat_poplevel ();
3152   return end_stmt_group ();
3153 }
3154 \f
3155 /* Subroutine of gnat_to_gnu to translate gnat_node, an
3156    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
3157
3158 static tree
3159 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
3160 {
3161   tree gnu_jmpsave_decl = NULL_TREE;
3162   tree gnu_jmpbuf_decl = NULL_TREE;
3163   /* If just annotating, ignore all EH and cleanups.  */
3164   bool gcc_zcx = (!type_annotate_only
3165                   && Present (Exception_Handlers (gnat_node))
3166                   && Exception_Mechanism == Back_End_Exceptions);
3167   bool setjmp_longjmp
3168     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
3169        && Exception_Mechanism == Setjmp_Longjmp);
3170   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
3171   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
3172   tree gnu_inner_block; /* The statement(s) for the block itself.  */
3173   tree gnu_result;
3174   tree gnu_expr;
3175   Node_Id gnat_temp;
3176
3177   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
3178      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
3179      add_cleanup, and when we leave the binding, end_stmt_group will create
3180      the TRY_FINALLY_EXPR.
3181
3182      ??? The region level calls down there have been specifically put in place
3183      for a ZCX context and currently the order in which things are emitted
3184      (region/handlers) is different from the SJLJ case. Instead of putting
3185      other calls with different conditions at other places for the SJLJ case,
3186      it seems cleaner to reorder things for the SJLJ case and generalize the
3187      condition to make it not ZCX specific.
3188
3189      If there are any exceptions or cleanup processing involved, we need an
3190      outer statement group (for Setjmp_Longjmp) and binding level.  */
3191   if (binding_for_block)
3192     {
3193       start_stmt_group ();
3194       gnat_pushlevel ();
3195     }
3196
3197   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
3198      area for address of previous buffer.  Do this first since we need to have
3199      the setjmp buf known for any decls in this block.  */
3200   if (setjmp_longjmp)
3201     {
3202       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
3203                                           NULL_TREE, jmpbuf_ptr_type,
3204                                           build_call_0_expr (get_jmpbuf_decl),
3205                                           false, false, false, false, NULL,
3206                                           gnat_node);
3207       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
3208
3209       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
3210          because of the unstructured form of EH used by setjmp_longjmp, there
3211          might be forward edges going to __builtin_setjmp receivers on which
3212          it is uninitialized, although they will never be actually taken.  */
3213       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
3214       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
3215                                          NULL_TREE, jmpbuf_type,
3216                                          NULL_TREE, false, false, false, false,
3217                                          NULL, gnat_node);
3218       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
3219
3220       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
3221
3222       /* When we exit this block, restore the saved value.  */
3223       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
3224                    End_Label (gnat_node));
3225     }
3226
3227   /* If we are to call a function when exiting this block, add a cleanup
3228      to the binding level we made above.  Note that add_cleanup is FIFO
3229      so we must register this cleanup after the EH cleanup just above.  */
3230   if (at_end)
3231     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
3232                  End_Label (gnat_node));
3233
3234   /* Now build the tree for the declarations and statements inside this block.
3235      If this is SJLJ, set our jmp_buf as the current buffer.  */
3236   start_stmt_group ();
3237
3238   if (setjmp_longjmp)
3239     add_stmt (build_call_1_expr (set_jmpbuf_decl,
3240                                  build_unary_op (ADDR_EXPR, NULL_TREE,
3241                                                  gnu_jmpbuf_decl)));
3242
3243   if (Present (First_Real_Statement (gnat_node)))
3244     process_decls (Statements (gnat_node), Empty,
3245                    First_Real_Statement (gnat_node), true, true);
3246
3247   /* Generate code for each statement in the block.  */
3248   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3249                     ? First_Real_Statement (gnat_node)
3250                     : First (Statements (gnat_node)));
3251        Present (gnat_temp); gnat_temp = Next (gnat_temp))
3252     add_stmt (gnat_to_gnu (gnat_temp));
3253   gnu_inner_block = end_stmt_group ();
3254
3255   /* Now generate code for the two exception models, if either is relevant for
3256      this block.  */
3257   if (setjmp_longjmp)
3258     {
3259       tree *gnu_else_ptr = 0;
3260       tree gnu_handler;
3261
3262       /* Make a binding level for the exception handling declarations and code
3263          and set up gnu_except_ptr_stack for the handlers to use.  */
3264       start_stmt_group ();
3265       gnat_pushlevel ();
3266
3267       push_stack (&gnu_except_ptr_stack, NULL_TREE,
3268                   create_var_decl (get_identifier ("EXCEPT_PTR"),
3269                                    NULL_TREE,
3270                                    build_pointer_type (except_type_node),
3271                                    build_call_0_expr (get_excptr_decl), false,
3272                                    false, false, false, NULL, gnat_node));
3273
3274       /* Generate code for each handler. The N_Exception_Handler case does the
3275          real work and returns a COND_EXPR for each handler, which we chain
3276          together here.  */
3277       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3278            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
3279         {
3280           gnu_expr = gnat_to_gnu (gnat_temp);
3281
3282           /* If this is the first one, set it as the outer one. Otherwise,
3283              point the "else" part of the previous handler to us. Then point
3284              to our "else" part.  */
3285           if (!gnu_else_ptr)
3286             add_stmt (gnu_expr);
3287           else
3288             *gnu_else_ptr = gnu_expr;
3289
3290           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3291         }
3292
3293       /* If none of the exception handlers did anything, re-raise but do not
3294          defer abortion.  */
3295       gnu_expr = build_call_1_expr (raise_nodefer_decl,
3296                                     TREE_VALUE (gnu_except_ptr_stack));
3297       set_expr_location_from_node
3298         (gnu_expr,
3299          Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
3300
3301       if (gnu_else_ptr)
3302         *gnu_else_ptr = gnu_expr;
3303       else
3304         add_stmt (gnu_expr);
3305
3306       /* End the binding level dedicated to the exception handlers and get the
3307          whole statement group.  */
3308       pop_stack (&gnu_except_ptr_stack);
3309       gnat_poplevel ();
3310       gnu_handler = end_stmt_group ();
3311
3312       /* If the setjmp returns 1, we restore our incoming longjmp value and
3313          then check the handlers.  */
3314       start_stmt_group ();
3315       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
3316                                              gnu_jmpsave_decl),
3317                           gnat_node);
3318       add_stmt (gnu_handler);
3319       gnu_handler = end_stmt_group ();
3320
3321       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
3322       gnu_result = build3 (COND_EXPR, void_type_node,
3323                            (build_call_1_expr
3324                             (setjmp_decl,
3325                              build_unary_op (ADDR_EXPR, NULL_TREE,
3326                                              gnu_jmpbuf_decl))),
3327                            gnu_handler, gnu_inner_block);
3328     }
3329   else if (gcc_zcx)
3330     {
3331       tree gnu_handlers;
3332
3333       /* First make a block containing the handlers.  */
3334       start_stmt_group ();
3335       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3336            Present (gnat_temp);
3337            gnat_temp = Next_Non_Pragma (gnat_temp))
3338         add_stmt (gnat_to_gnu (gnat_temp));
3339       gnu_handlers = end_stmt_group ();
3340
3341       /* Now make the TRY_CATCH_EXPR for the block.  */
3342       gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
3343                            gnu_inner_block, gnu_handlers);
3344     }
3345   else
3346     gnu_result = gnu_inner_block;
3347
3348   /* Now close our outer block, if we had to make one.  */
3349   if (binding_for_block)
3350     {
3351       add_stmt (gnu_result);
3352       gnat_poplevel ();
3353       gnu_result = end_stmt_group ();
3354     }
3355
3356   return gnu_result;
3357 }
3358 \f
3359 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3360    to a GCC tree, which is returned.  This is the variant for Setjmp_Longjmp
3361    exception handling.  */
3362
3363 static tree
3364 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
3365 {
3366   /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
3367      an "if" statement to select the proper exceptions.  For "Others", exclude
3368      exceptions where Handled_By_Others is nonzero unless the All_Others flag
3369      is set. For "Non-ada", accept an exception if "Lang" is 'V'.  */
3370   tree gnu_choice = integer_zero_node;
3371   tree gnu_body = build_stmt_group (Statements (gnat_node), false);
3372   Node_Id gnat_temp;
3373
3374   for (gnat_temp = First (Exception_Choices (gnat_node));
3375        gnat_temp; gnat_temp = Next (gnat_temp))
3376     {
3377       tree this_choice;
3378
3379       if (Nkind (gnat_temp) == N_Others_Choice)
3380         {
3381           if (All_Others (gnat_temp))
3382             this_choice = integer_one_node;
3383           else
3384             this_choice
3385               = build_binary_op
3386                 (EQ_EXPR, boolean_type_node,
3387                  convert
3388                  (integer_type_node,
3389                   build_component_ref
3390                   (build_unary_op
3391                    (INDIRECT_REF, NULL_TREE,
3392                     TREE_VALUE (gnu_except_ptr_stack)),
3393                    get_identifier ("not_handled_by_others"), NULL_TREE,
3394                    false)),
3395                  integer_zero_node);
3396         }
3397
3398       else if (Nkind (gnat_temp) == N_Identifier
3399                || Nkind (gnat_temp) == N_Expanded_Name)
3400         {
3401           Entity_Id gnat_ex_id = Entity (gnat_temp);
3402           tree gnu_expr;
3403
3404           /* Exception may be a renaming. Recover original exception which is
3405              the one elaborated and registered.  */
3406           if (Present (Renamed_Object (gnat_ex_id)))
3407             gnat_ex_id = Renamed_Object (gnat_ex_id);
3408
3409           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3410
3411           this_choice
3412             = build_binary_op
3413               (EQ_EXPR, boolean_type_node, TREE_VALUE (gnu_except_ptr_stack),
3414                convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
3415                         build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3416
3417           /* If this is the distinguished exception "Non_Ada_Error" (and we are
3418              in VMS mode), also allow a non-Ada exception (a VMS condition) t
3419              match.  */
3420           if (Is_Non_Ada_Error (Entity (gnat_temp)))
3421             {
3422               tree gnu_comp
3423                 = build_component_ref
3424                   (build_unary_op (INDIRECT_REF, NULL_TREE,
3425                                    TREE_VALUE (gnu_except_ptr_stack)),
3426                    get_identifier ("lang"), NULL_TREE, false);
3427
3428               this_choice
3429                 = build_binary_op
3430                   (TRUTH_ORIF_EXPR, boolean_type_node,
3431                    build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp,
3432                                     build_int_cst (TREE_TYPE (gnu_comp), 'V')),
3433                    this_choice);
3434             }
3435         }
3436       else
3437         gcc_unreachable ();
3438
3439       gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
3440                                     gnu_choice, this_choice);
3441     }
3442
3443   return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
3444 }
3445 \f
3446 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3447    to a GCC tree, which is returned.  This is the variant for ZCX.  */
3448
3449 static tree
3450 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
3451 {
3452   tree gnu_etypes_list = NULL_TREE;
3453   tree gnu_expr;
3454   tree gnu_etype;
3455   tree gnu_current_exc_ptr;
3456   tree gnu_incoming_exc_ptr;
3457   Node_Id gnat_temp;
3458
3459   /* We build a TREE_LIST of nodes representing what exception types this
3460      handler can catch, with special cases for others and all others cases.
3461
3462      Each exception type is actually identified by a pointer to the exception
3463      id, or to a dummy object for "others" and "all others".  */
3464   for (gnat_temp = First (Exception_Choices (gnat_node));
3465        gnat_temp; gnat_temp = Next (gnat_temp))
3466     {
3467       if (Nkind (gnat_temp) == N_Others_Choice)
3468         {
3469           tree gnu_expr
3470             = All_Others (gnat_temp) ? all_others_decl : others_decl;
3471
3472           gnu_etype
3473             = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3474         }
3475       else if (Nkind (gnat_temp) == N_Identifier
3476                || Nkind (gnat_temp) == N_Expanded_Name)
3477         {
3478           Entity_Id gnat_ex_id = Entity (gnat_temp);
3479
3480           /* Exception may be a renaming. Recover original exception which is
3481              the one elaborated and registered.  */
3482           if (Present (Renamed_Object (gnat_ex_id)))
3483             gnat_ex_id = Renamed_Object (gnat_ex_id);
3484
3485           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3486           gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3487
3488           /* The Non_Ada_Error case for VMS exceptions is handled
3489              by the personality routine.  */
3490         }
3491       else
3492         gcc_unreachable ();
3493
3494       /* The GCC interface expects NULL to be passed for catch all handlers, so
3495          it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
3496          is integer_zero_node.  It would not work, however, because GCC's
3497          notion of "catch all" is stronger than our notion of "others".  Until
3498          we correctly use the cleanup interface as well, doing that would
3499          prevent the "all others" handlers from being seen, because nothing
3500          can be caught beyond a catch all from GCC's point of view.  */
3501       gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3502     }
3503
3504   start_stmt_group ();
3505   gnat_pushlevel ();
3506
3507   /* Expand a call to the begin_handler hook at the beginning of the handler,
3508      and arrange for a call to the end_handler hook to occur on every possible
3509      exit path.
3510
3511      The hooks expect a pointer to the low level occurrence. This is required
3512      for our stack management scheme because a raise inside the handler pushes
3513      a new occurrence on top of the stack, which means that this top does not
3514      necessarily match the occurrence this handler was dealing with.
3515
3516      __builtin_eh_pointer references the exception occurrence being
3517      propagated. Upon handler entry, this is the exception for which the
3518      handler is triggered. This might not be the case upon handler exit,
3519      however, as we might have a new occurrence propagated by the handler's
3520      body, and the end_handler hook called as a cleanup in this context.
3521
3522      We use a local variable to retrieve the incoming value at handler entry
3523      time, and reuse it to feed the end_handler hook's argument at exit.  */
3524
3525   gnu_current_exc_ptr
3526     = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
3527                        1, integer_zero_node);
3528   gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3529                                           ptr_type_node, gnu_current_exc_ptr,
3530                                           false, false, false, false, NULL,
3531                                           gnat_node);
3532
3533   add_stmt_with_node (build_call_1_expr (begin_handler_decl,
3534                                          gnu_incoming_exc_ptr),
3535                       gnat_node);
3536   /* ??? We don't seem to have an End_Label at hand to set the location.  */
3537   add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
3538                Empty);
3539   add_stmt_list (Statements (gnat_node));
3540   gnat_poplevel ();
3541
3542   return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
3543                  end_stmt_group ());
3544 }
3545 \f
3546 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
3547
3548 static void
3549 Compilation_Unit_to_gnu (Node_Id gnat_node)
3550 {
3551   const Node_Id gnat_unit = Unit (gnat_node);
3552   const bool body_p = (Nkind (gnat_unit) == N_Package_Body
3553                        || Nkind (gnat_unit) == N_Subprogram_Body);
3554   const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
3555   /* Make the decl for the elaboration procedure.  */
3556   tree gnu_elab_proc_decl
3557     = create_subprog_decl
3558       (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
3559        NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, gnat_unit);
3560   struct elab_info *info;
3561
3562   push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
3563   DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
3564
3565   /* Initialize the information structure for the function.  */
3566   allocate_struct_function (gnu_elab_proc_decl, false);
3567   Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
3568   current_function_decl = NULL_TREE;
3569   set_cfun (NULL);
3570   start_stmt_group ();
3571   gnat_pushlevel ();
3572
3573   current_function_decl = NULL_TREE;
3574
3575   start_stmt_group ();
3576   gnat_pushlevel ();
3577
3578   /* For a body, first process the spec if there is one.  */
3579   if (Nkind (Unit (gnat_node)) == N_Package_Body
3580       || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3581               && !Acts_As_Spec (gnat_node)))
3582     {
3583       add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
3584       finalize_from_with_types ();
3585   &nb