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       /* ??? We need to unshare the initializer if the object is external
1061          as such objects are not marked for unsharing if we are not at the
1062          global level.  This should be fixed in add_decl_expr.  */
1063       if ((constant_only && !address_of_constant) || !require_lvalue)
1064         gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
1065     }
1066
1067   *gnu_result_type_p = gnu_result_type;
1068
1069   return gnu_result;
1070 }
1071 \f
1072 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
1073    any statements we generate.  */
1074
1075 static tree
1076 Pragma_to_gnu (Node_Id gnat_node)
1077 {
1078   Node_Id gnat_temp;
1079   tree gnu_result = alloc_stmt_list ();
1080
1081   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1082      annotating types.  */
1083   if (type_annotate_only
1084       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1085     return gnu_result;
1086
1087   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1088     {
1089     case Pragma_Inspection_Point:
1090       /* Do nothing at top level: all such variables are already viewable.  */
1091       if (global_bindings_p ())
1092         break;
1093
1094       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1095            Present (gnat_temp);
1096            gnat_temp = Next (gnat_temp))
1097         {
1098           Node_Id gnat_expr = Expression (gnat_temp);
1099           tree gnu_expr = gnat_to_gnu (gnat_expr);
1100           int use_address;
1101           enum machine_mode mode;
1102           tree asm_constraint = NULL_TREE;
1103 #ifdef ASM_COMMENT_START
1104           char *comment;
1105 #endif
1106
1107           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1108             gnu_expr = TREE_OPERAND (gnu_expr, 0);
1109
1110           /* Use the value only if it fits into a normal register,
1111              otherwise use the address.  */
1112           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1113           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1114                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1115                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1116
1117           if (use_address)
1118             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1119
1120 #ifdef ASM_COMMENT_START
1121           comment = concat (ASM_COMMENT_START,
1122                             " inspection point: ",
1123                             Get_Name_String (Chars (gnat_expr)),
1124                             use_address ? " address" : "",
1125                             " is in %0",
1126                             NULL);
1127           asm_constraint = build_string (strlen (comment), comment);
1128           free (comment);
1129 #endif
1130           gnu_expr = build5 (ASM_EXPR, void_type_node,
1131                              asm_constraint,
1132                              NULL_TREE,
1133                              tree_cons
1134                              (build_tree_list (NULL_TREE,
1135                                                build_string (1, "g")),
1136                               gnu_expr, NULL_TREE),
1137                              NULL_TREE, NULL_TREE);
1138           ASM_VOLATILE_P (gnu_expr) = 1;
1139           set_expr_location_from_node (gnu_expr, gnat_node);
1140           append_to_statement_list (gnu_expr, &gnu_result);
1141         }
1142       break;
1143
1144     case Pragma_Optimize:
1145       switch (Chars (Expression
1146                      (First (Pragma_Argument_Associations (gnat_node)))))
1147         {
1148         case Name_Time:  case Name_Space:
1149           if (!optimize)
1150             post_error ("insufficient -O value?", gnat_node);
1151           break;
1152
1153         case Name_Off:
1154           if (optimize)
1155             post_error ("must specify -O0?", gnat_node);
1156           break;
1157
1158         default:
1159           gcc_unreachable ();
1160         }
1161       break;
1162
1163     case Pragma_Reviewable:
1164       if (write_symbols == NO_DEBUG)
1165         post_error ("must specify -g?", gnat_node);
1166       break;
1167     }
1168
1169   return gnu_result;
1170 }
1171 \f
1172 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1173    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
1174    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
1175
1176 static tree
1177 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1178 {
1179   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1180   tree gnu_type = TREE_TYPE (gnu_prefix);
1181   tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1182   bool prefix_unused = false;
1183
1184   /* If the input is a NULL_EXPR, make a new one.  */
1185   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1186     {
1187       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1188       *gnu_result_type_p = gnu_result_type;
1189       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1190     }
1191
1192   switch (attribute)
1193     {
1194     case Attr_Pos:
1195     case Attr_Val:
1196       /* These are just conversions since representation clauses for
1197          enumeration types are handled in the front-end.  */
1198       {
1199         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1200         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1201         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1202         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1203                                          checkp, checkp, true, gnat_node);
1204       }
1205       break;
1206
1207     case Attr_Pred:
1208     case Attr_Succ:
1209       /* These just add or subtract the constant 1 since representation
1210          clauses for enumeration types are handled in the front-end.  */
1211       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1212       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1213
1214       if (Do_Range_Check (First (Expressions (gnat_node))))
1215         {
1216           gnu_expr = gnat_protect_expr (gnu_expr);
1217           gnu_expr
1218             = emit_check
1219               (build_binary_op (EQ_EXPR, boolean_type_node,
1220                                 gnu_expr,
1221                                 attribute == Attr_Pred
1222                                 ? TYPE_MIN_VALUE (gnu_result_type)
1223                                 : TYPE_MAX_VALUE (gnu_result_type)),
1224                gnu_expr, CE_Range_Check_Failed, gnat_node);
1225         }
1226
1227       gnu_result
1228         = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1229                            gnu_result_type, gnu_expr,
1230                            convert (gnu_result_type, integer_one_node));
1231       break;
1232
1233     case Attr_Address:
1234     case Attr_Unrestricted_Access:
1235       /* Conversions don't change addresses but can cause us to miss the
1236          COMPONENT_REF case below, so strip them off.  */
1237       gnu_prefix = remove_conversions (gnu_prefix,
1238                                        !Must_Be_Byte_Aligned (gnat_node));
1239
1240       /* If we are taking 'Address of an unconstrained object, this is the
1241          pointer to the underlying array.  */
1242       if (attribute == Attr_Address)
1243         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1244
1245       /* If we are building a static dispatch table, we have to honor
1246          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1247          with the C++ ABI.  We do it in the non-static case as well,
1248          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
1249       else if (TARGET_VTABLE_USES_DESCRIPTORS
1250                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1251         {
1252           tree gnu_field, gnu_list = NULL_TREE, t;
1253           /* Descriptors can only be built here for top-level functions.  */
1254           bool build_descriptor = (global_bindings_p () != 0);
1255           int i;
1256
1257           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1258
1259           /* If we're not going to build the descriptor, we have to retrieve
1260              the one which will be built by the linker (or by the compiler
1261              later if a static chain is requested).  */
1262           if (!build_descriptor)
1263             {
1264               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1265               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1266                                          gnu_result);
1267               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1268             }
1269
1270           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1271                i < TARGET_VTABLE_USES_DESCRIPTORS;
1272                gnu_field = TREE_CHAIN (gnu_field), i++)
1273             {
1274               if (build_descriptor)
1275                 {
1276                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1277                               build_int_cst (NULL_TREE, i));
1278                   TREE_CONSTANT (t) = 1;
1279                 }
1280               else
1281                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1282                             gnu_field, NULL_TREE);
1283
1284               gnu_list = tree_cons (gnu_field, t, gnu_list);
1285             }
1286
1287           gnu_result = gnat_build_constructor (gnu_result_type, gnu_list);
1288           break;
1289         }
1290
1291       /* ... fall through ... */
1292
1293     case Attr_Access:
1294     case Attr_Unchecked_Access:
1295     case Attr_Code_Address:
1296       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1297       gnu_result
1298         = build_unary_op (((attribute == Attr_Address
1299                             || attribute == Attr_Unrestricted_Access)
1300                            && !Must_Be_Byte_Aligned (gnat_node))
1301                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
1302                           gnu_result_type, gnu_prefix);
1303
1304       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1305          don't try to build a trampoline.  */
1306       if (attribute == Attr_Code_Address)
1307         {
1308           for (gnu_expr = gnu_result;
1309                CONVERT_EXPR_P (gnu_expr);
1310                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1311             TREE_CONSTANT (gnu_expr) = 1;
1312
1313           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1314             TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1315         }
1316
1317       /* For other address attributes applied to a nested function,
1318          find an inner ADDR_EXPR and annotate it so that we can issue
1319          a useful warning with -Wtrampolines.  */
1320       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1321         {
1322           for (gnu_expr = gnu_result;
1323                CONVERT_EXPR_P (gnu_expr);
1324                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1325             ;
1326
1327           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1328               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1329             {
1330               set_expr_location_from_node (gnu_expr, gnat_node);
1331
1332               /* Check that we're not violating the No_Implicit_Dynamic_Code
1333                  restriction.  Be conservative if we don't know anything
1334                  about the trampoline strategy for the target.  */
1335               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1336             }
1337         }
1338       break;
1339
1340     case Attr_Pool_Address:
1341       {
1342         tree gnu_obj_type;
1343         tree gnu_ptr = gnu_prefix;
1344
1345         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1346
1347         /* If this is an unconstrained array, we know the object has been
1348            allocated with the template in front of the object.  So compute
1349            the template address.  */
1350         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1351           gnu_ptr
1352             = convert (build_pointer_type
1353                        (TYPE_OBJECT_RECORD_TYPE
1354                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1355                        gnu_ptr);
1356
1357         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1358         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1359             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1360           {
1361             tree gnu_char_ptr_type
1362               = build_pointer_type (unsigned_char_type_node);
1363             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1364             tree gnu_byte_offset
1365               = convert (sizetype,
1366                          size_diffop (size_zero_node, gnu_pos));
1367             gnu_byte_offset
1368               = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
1369
1370             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1371             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1372                                        gnu_ptr, gnu_pos);
1373           }
1374
1375         gnu_result = convert (gnu_result_type, gnu_ptr);
1376       }
1377       break;
1378
1379     case Attr_Size:
1380     case Attr_Object_Size:
1381     case Attr_Value_Size:
1382     case Attr_Max_Size_In_Storage_Elements:
1383       gnu_expr = gnu_prefix;
1384
1385       /* Remove NOPs and conversions between original and packable version
1386          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1387          to see if a COMPONENT_REF was involved.  */
1388       while (TREE_CODE (gnu_expr) == NOP_EXPR
1389              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1390                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1391                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1392                     == RECORD_TYPE
1393                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1394                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1395         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1396
1397       gnu_prefix = remove_conversions (gnu_prefix, true);
1398       prefix_unused = true;
1399       gnu_type = TREE_TYPE (gnu_prefix);
1400
1401       /* Replace an unconstrained array type with the type of the underlying
1402          array.  We can't do this with a call to maybe_unconstrained_array
1403          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1404          use the record type that will be used to allocate the object and its
1405          template.  */
1406       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1407         {
1408           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1409           if (attribute != Attr_Max_Size_In_Storage_Elements)
1410             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1411         }
1412
1413       /* If we're looking for the size of a field, return the field size.
1414          Otherwise, if the prefix is an object, or if we're looking for
1415          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1416          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1417       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1418         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1419       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1420                || attribute == Attr_Object_Size
1421                || attribute == Attr_Max_Size_In_Storage_Elements)
1422         {
1423           /* If the prefix is an object of a padded type, the GCC size isn't
1424              relevant to the programmer.  Normally what we want is the RM size,
1425              which was set from the specified size, but if it was not set, we
1426              want the size of the field.  Using the MAX of those two produces
1427              the right result in all cases.  Don't use the size of the field
1428              if it's self-referential, since that's never what's wanted.  */
1429           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1430               && TYPE_IS_PADDING_P (gnu_type)
1431               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1432             {
1433               gnu_result = rm_size (gnu_type);
1434               if (!CONTAINS_PLACEHOLDER_P
1435                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1436                 gnu_result
1437                   = size_binop (MAX_EXPR, gnu_result,
1438                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1439             }
1440           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1441             {
1442               Node_Id gnat_deref = Prefix (gnat_node);
1443               Node_Id gnat_actual_subtype
1444                 = Actual_Designated_Subtype (gnat_deref);
1445               tree gnu_ptr_type
1446                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1447
1448               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1449                   && Present (gnat_actual_subtype))
1450                 {
1451                   tree gnu_actual_obj_type
1452                     = gnat_to_gnu_type (gnat_actual_subtype);
1453                   gnu_type
1454                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1455                                                       gnu_actual_obj_type,
1456                                                       get_identifier ("SIZE"),
1457                                                       false);
1458                 }
1459
1460               gnu_result = TYPE_SIZE (gnu_type);
1461             }
1462           else
1463             gnu_result = TYPE_SIZE (gnu_type);
1464         }
1465       else
1466         gnu_result = rm_size (gnu_type);
1467
1468       /* Deal with a self-referential size by returning the maximum size for
1469          a type and by qualifying the size with the object otherwise.  */
1470       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1471         {
1472           if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1473             gnu_result = max_size (gnu_result, true);
1474           else
1475             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1476         }
1477
1478       /* If the type contains a template, subtract its size.  */
1479       if (TREE_CODE (gnu_type) == RECORD_TYPE
1480           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1481         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1482                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1483
1484       /* For 'Max_Size_In_Storage_Elements, adjust the unit.  */
1485       if (attribute == Attr_Max_Size_In_Storage_Elements)
1486         gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1487
1488       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1489       break;
1490
1491     case Attr_Alignment:
1492       {
1493         unsigned int align;
1494
1495         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1496             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1497           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1498
1499         gnu_type = TREE_TYPE (gnu_prefix);
1500         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1501         prefix_unused = true;
1502
1503         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1504           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1505         else
1506           {
1507             Node_Id gnat_prefix = Prefix (gnat_node);
1508             Entity_Id gnat_type = Etype (gnat_prefix);
1509             unsigned int double_align;
1510             bool is_capped_double, align_clause;
1511
1512             /* If the default alignment of "double" or larger scalar types is
1513                specifically capped and there is an alignment clause neither
1514                on the type nor on the prefix itself, return the cap.  */
1515             if ((double_align = double_float_alignment) > 0)
1516               is_capped_double
1517                 = is_double_float_or_array (gnat_type, &align_clause);
1518             else if ((double_align = double_scalar_alignment) > 0)
1519               is_capped_double
1520                 = is_double_scalar_or_array (gnat_type, &align_clause);
1521             else
1522               is_capped_double = align_clause = false;
1523
1524             if (is_capped_double
1525                 && Nkind (gnat_prefix) == N_Identifier
1526                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1527               align_clause = true;
1528
1529             if (is_capped_double && !align_clause)
1530               align = double_align;
1531             else
1532               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1533           }
1534
1535         gnu_result = size_int (align);
1536       }
1537       break;
1538
1539     case Attr_First:
1540     case Attr_Last:
1541     case Attr_Range_Length:
1542       prefix_unused = true;
1543
1544       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1545         {
1546           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1547
1548           if (attribute == Attr_First)
1549             gnu_result = TYPE_MIN_VALUE (gnu_type);
1550           else if (attribute == Attr_Last)
1551             gnu_result = TYPE_MAX_VALUE (gnu_type);
1552           else
1553             gnu_result
1554               = build_binary_op
1555                 (MAX_EXPR, get_base_type (gnu_result_type),
1556                  build_binary_op
1557                  (PLUS_EXPR, get_base_type (gnu_result_type),
1558                   build_binary_op (MINUS_EXPR,
1559                                    get_base_type (gnu_result_type),
1560                                    convert (gnu_result_type,
1561                                             TYPE_MAX_VALUE (gnu_type)),
1562                                    convert (gnu_result_type,
1563                                             TYPE_MIN_VALUE (gnu_type))),
1564                   convert (gnu_result_type, integer_one_node)),
1565                  convert (gnu_result_type, integer_zero_node));
1566
1567           break;
1568         }
1569
1570       /* ... fall through ... */
1571
1572     case Attr_Length:
1573       {
1574         int Dimension = (Present (Expressions (gnat_node))
1575                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1576                          : 1), i;
1577         struct parm_attr_d *pa = NULL;
1578         Entity_Id gnat_param = Empty;
1579
1580         /* Make sure any implicit dereference gets done.  */
1581         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1582         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1583         /* We treat unconstrained array In parameters specially.  */
1584         if (Nkind (Prefix (gnat_node)) == N_Identifier
1585             && !Is_Constrained (Etype (Prefix (gnat_node)))
1586             && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1587           gnat_param = Entity (Prefix (gnat_node));
1588         gnu_type = TREE_TYPE (gnu_prefix);
1589         prefix_unused = true;
1590         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1591
1592         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1593           {
1594             int ndim;
1595             tree gnu_type_temp;
1596
1597             for (ndim = 1, gnu_type_temp = gnu_type;
1598                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1599                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1600                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1601               ;
1602
1603             Dimension = ndim + 1 - Dimension;
1604           }
1605
1606         for (i = 1; i < Dimension; i++)
1607           gnu_type = TREE_TYPE (gnu_type);
1608
1609         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1610
1611         /* When not optimizing, look up the slot associated with the parameter
1612            and the dimension in the cache and create a new one on failure.  */
1613         if (!optimize && Present (gnat_param))
1614           {
1615             for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
1616               if (pa->id == gnat_param && pa->dim == Dimension)
1617                 break;
1618
1619             if (!pa)
1620               {
1621                 pa = GGC_CNEW (struct parm_attr_d);
1622                 pa->id = gnat_param;
1623                 pa->dim = Dimension;
1624                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1625               }
1626           }
1627
1628         /* Return the cached expression or build a new one.  */
1629         if (attribute == Attr_First)
1630           {
1631             if (pa && pa->first)
1632               {
1633                 gnu_result = pa->first;
1634                 break;
1635               }
1636
1637             gnu_result
1638               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1639           }
1640
1641         else if (attribute == Attr_Last)
1642           {
1643             if (pa && pa->last)
1644               {
1645                 gnu_result = pa->last;
1646                 break;
1647               }
1648
1649             gnu_result
1650               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1651           }
1652
1653         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1654           {
1655             if (pa && pa->length)
1656               {
1657                 gnu_result = pa->length;
1658                 break;
1659               }
1660             else
1661               {
1662                 /* We used to compute the length as max (hb - lb + 1, 0),
1663                    which could overflow for some cases of empty arrays, e.g.
1664                    when lb == index_type'first.  We now compute the length as
1665                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1666                    much rarer cases, for extremely large arrays we expect
1667                    never to encounter in practice.  In addition, the former
1668                    computation required the use of potentially constraining
1669                    signed arithmetic while the latter doesn't.  Note that
1670                    the comparison must be done in the original index type,
1671                    to avoid any overflow during the conversion.  */
1672                 tree comp_type = get_base_type (gnu_result_type);
1673                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1674                 tree lb = TYPE_MIN_VALUE (index_type);
1675                 tree hb = TYPE_MAX_VALUE (index_type);
1676                 gnu_result
1677                   = build_binary_op (PLUS_EXPR, comp_type,
1678                                      build_binary_op (MINUS_EXPR,
1679                                                       comp_type,
1680                                                       convert (comp_type, hb),
1681                                                       convert (comp_type, lb)),
1682                                      convert (comp_type, integer_one_node));
1683                 gnu_result
1684                   = build_cond_expr (comp_type,
1685                                      build_binary_op (GE_EXPR,
1686                                                       boolean_type_node,
1687                                                       hb, lb),
1688                                      gnu_result,
1689                                      convert (comp_type, integer_zero_node));
1690               }
1691           }
1692
1693         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1694            handling.  Note that these attributes could not have been used on
1695            an unconstrained array type.  */
1696         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1697
1698         /* Cache the expression we have just computed.  Since we want to do it
1699            at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1700            create the temporary.  */
1701         if (pa)
1702           {
1703             gnu_result
1704               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1705             TREE_SIDE_EFFECTS (gnu_result) = 1;
1706             if (attribute == Attr_First)
1707               pa->first = gnu_result;
1708             else if (attribute == Attr_Last)
1709               pa->last = gnu_result;
1710             else
1711               pa->length = gnu_result;
1712           }
1713
1714         /* Set the source location onto the predicate of the condition in the
1715            'Length case but do not do it if the expression is cached to avoid
1716            messing up the debug info.  */
1717         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1718                  && TREE_CODE (gnu_result) == COND_EXPR
1719                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1720           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1721                                        gnat_node);
1722
1723         break;
1724       }
1725
1726     case Attr_Bit_Position:
1727     case Attr_Position:
1728     case Attr_First_Bit:
1729     case Attr_Last_Bit:
1730     case Attr_Bit:
1731       {
1732         HOST_WIDE_INT bitsize;
1733         HOST_WIDE_INT bitpos;
1734         tree gnu_offset;
1735         tree gnu_field_bitpos;
1736         tree gnu_field_offset;
1737         tree gnu_inner;
1738         enum machine_mode mode;
1739         int unsignedp, volatilep;
1740
1741         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1742         gnu_prefix = remove_conversions (gnu_prefix, true);
1743         prefix_unused = true;
1744
1745         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1746            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1747         if (attribute == Attr_Bit
1748             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1749             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1750           {
1751             gnu_result = integer_zero_node;
1752             break;
1753           }
1754
1755         else
1756           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1757                       || (attribute == Attr_Bit_Position
1758                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1759
1760         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1761                              &mode, &unsignedp, &volatilep, false);
1762
1763         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1764           {
1765             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1766             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1767
1768             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1769                  TREE_CODE (gnu_inner) == COMPONENT_REF
1770                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1771                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1772               {
1773                 gnu_field_bitpos
1774                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1775                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1776                 gnu_field_offset
1777                   = size_binop (PLUS_EXPR, gnu_field_offset,
1778                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1779               }
1780           }
1781         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1782           {
1783             gnu_field_bitpos = bit_position (gnu_prefix);
1784             gnu_field_offset = byte_position (gnu_prefix);
1785           }
1786         else
1787           {
1788             gnu_field_bitpos = bitsize_zero_node;
1789             gnu_field_offset = size_zero_node;
1790           }
1791
1792         switch (attribute)
1793           {
1794           case Attr_Position:
1795             gnu_result = gnu_field_offset;
1796             break;
1797
1798           case Attr_First_Bit:
1799           case Attr_Bit:
1800             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1801             break;
1802
1803           case Attr_Last_Bit:
1804             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1805             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1806                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1807             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1808                                      bitsize_one_node);
1809             break;
1810
1811           case Attr_Bit_Position:
1812             gnu_result = gnu_field_bitpos;
1813             break;
1814                 }
1815
1816         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1817            handling.  */
1818         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1819         break;
1820       }
1821
1822     case Attr_Min:
1823     case Attr_Max:
1824       {
1825         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1826         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1827
1828         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1829         gnu_result = build_binary_op (attribute == Attr_Min
1830                                       ? MIN_EXPR : MAX_EXPR,
1831                                       gnu_result_type, gnu_lhs, gnu_rhs);
1832       }
1833       break;
1834
1835     case Attr_Passed_By_Reference:
1836       gnu_result = size_int (default_pass_by_ref (gnu_type)
1837                              || must_pass_by_ref (gnu_type));
1838       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1839       break;
1840
1841     case Attr_Component_Size:
1842       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1843           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1844         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1845
1846       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1847       gnu_type = TREE_TYPE (gnu_prefix);
1848
1849       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1850         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1851
1852       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1853              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1854         gnu_type = TREE_TYPE (gnu_type);
1855
1856       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1857
1858       /* Note this size cannot be self-referential.  */
1859       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1860       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1861       prefix_unused = true;
1862       break;
1863
1864     case Attr_Null_Parameter:
1865       /* This is just a zero cast to the pointer type for our prefix and
1866          dereferenced.  */
1867       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1868       gnu_result
1869         = build_unary_op (INDIRECT_REF, NULL_TREE,
1870                           convert (build_pointer_type (gnu_result_type),
1871                                    integer_zero_node));
1872       TREE_PRIVATE (gnu_result) = 1;
1873       break;
1874
1875     case Attr_Mechanism_Code:
1876       {
1877         int code;
1878         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1879
1880         prefix_unused = true;
1881         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1882         if (Present (Expressions (gnat_node)))
1883           {
1884             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1885
1886             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1887                  i--, gnat_obj = Next_Formal (gnat_obj))
1888               ;
1889           }
1890
1891         code = Mechanism (gnat_obj);
1892         if (code == Default)
1893           code = ((present_gnu_tree (gnat_obj)
1894                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1895                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1896                             == PARM_DECL)
1897                            && (DECL_BY_COMPONENT_PTR_P
1898                                (get_gnu_tree (gnat_obj))))))
1899                   ? By_Reference : By_Copy);
1900         gnu_result = convert (gnu_result_type, size_int (- code));
1901       }
1902       break;
1903
1904     default:
1905       /* Say we have an unimplemented attribute.  Then set the value to be
1906          returned to be a zero and hope that's something we can convert to
1907          the type of this attribute.  */
1908       post_error ("unimplemented attribute", gnat_node);
1909       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1910       gnu_result = integer_zero_node;
1911       break;
1912     }
1913
1914   /* If this is an attribute where the prefix was unused, force a use of it if
1915      it has a side-effect.  But don't do it if the prefix is just an entity
1916      name.  However, if an access check is needed, we must do it.  See second
1917      example in AARM 11.6(5.e).  */
1918   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1919       && !Is_Entity_Name (Prefix (gnat_node)))
1920     gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1921                               gnu_prefix, gnu_result);
1922
1923   *gnu_result_type_p = gnu_result_type;
1924   return gnu_result;
1925 }
1926 \f
1927 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1928    to a GCC tree, which is returned.  */
1929
1930 static tree
1931 Case_Statement_to_gnu (Node_Id gnat_node)
1932 {
1933   tree gnu_result;
1934   tree gnu_expr;
1935   Node_Id gnat_when;
1936
1937   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1938   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1939
1940   /*  The range of values in a case statement is determined by the rules in
1941       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1942       of the expression. One exception arises in the case of a simple name that
1943       is parenthesized. This still has the Etype of the name, but since it is
1944       not a name, para 7 does not apply, and we need to go to the base type.
1945       This is the only case where parenthesization affects the dynamic
1946       semantics (i.e. the range of possible values at runtime that is covered
1947       by the others alternative.
1948
1949       Another exception is if the subtype of the expression is non-static.  In
1950       that case, we also have to use the base type.  */
1951   if (Paren_Count (Expression (gnat_node)) != 0
1952       || !Is_OK_Static_Subtype (Underlying_Type
1953                                 (Etype (Expression (gnat_node)))))
1954     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1955
1956   /* We build a SWITCH_EXPR that contains the code with interspersed
1957      CASE_LABEL_EXPRs for each label.  */
1958
1959   push_stack (&gnu_switch_label_stack, NULL_TREE,
1960               create_artificial_label (input_location));
1961   start_stmt_group ();
1962   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1963        Present (gnat_when);
1964        gnat_when = Next_Non_Pragma (gnat_when))
1965     {
1966       bool choices_added_p = false;
1967       Node_Id gnat_choice;
1968
1969       /* First compile all the different case choices for the current WHEN
1970          alternative.  */
1971       for (gnat_choice = First (Discrete_Choices (gnat_when));
1972            Present (gnat_choice); gnat_choice = Next (gnat_choice))
1973         {
1974           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1975
1976           switch (Nkind (gnat_choice))
1977             {
1978             case N_Range:
1979               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1980               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1981               break;
1982
1983             case N_Subtype_Indication:
1984               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1985                                                 (Constraint (gnat_choice))));
1986               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1987                                                   (Constraint (gnat_choice))));
1988               break;
1989
1990             case N_Identifier:
1991             case N_Expanded_Name:
1992               /* This represents either a subtype range or a static value of
1993                  some kind; Ekind says which.  */
1994               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1995                 {
1996                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1997
1998                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1999                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
2000                   break;
2001                 }
2002
2003               /* ... fall through ... */
2004
2005             case N_Character_Literal:
2006             case N_Integer_Literal:
2007               gnu_low = gnat_to_gnu (gnat_choice);
2008               break;
2009
2010             case N_Others_Choice:
2011               break;
2012
2013             default:
2014               gcc_unreachable ();
2015             }
2016
2017           /* If the case value is a subtype that raises Constraint_Error at
2018              run-time because of a wrong bound, then gnu_low or gnu_high is
2019              not translated into an INTEGER_CST.  In such a case, we need
2020              to ensure that the when statement is not added in the tree,
2021              otherwise it will crash the gimplifier.  */
2022           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2023               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2024             {
2025               add_stmt_with_node (build3
2026                                   (CASE_LABEL_EXPR, void_type_node,
2027                                    gnu_low, gnu_high,
2028                                    create_artificial_label (input_location)),
2029                                   gnat_choice);
2030               choices_added_p = true;
2031             }
2032         }
2033
2034       /* Push a binding level here in case variables are declared as we want
2035          them to be local to this set of statements instead of to the block
2036          containing the Case statement.  */
2037       if (choices_added_p)
2038         {
2039           add_stmt (build_stmt_group (Statements (gnat_when), true));
2040           add_stmt (build1 (GOTO_EXPR, void_type_node,
2041                             TREE_VALUE (gnu_switch_label_stack)));
2042         }
2043     }
2044
2045   /* Now emit a definition of the label all the cases branched to.  */
2046   add_stmt (build1 (LABEL_EXPR, void_type_node,
2047                     TREE_VALUE (gnu_switch_label_stack)));
2048   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2049                        end_stmt_group (), NULL_TREE);
2050   pop_stack (&gnu_switch_label_stack);
2051
2052   return gnu_result;
2053 }
2054 \f
2055 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2056    false, or the maximum value if MAX is true, of TYPE.  */
2057
2058 static bool
2059 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2060 {
2061   tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2062
2063   if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2064     return true;
2065
2066   if (TREE_CODE (val) == NOP_EXPR)
2067     val = (max
2068            ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2069            : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2070
2071   if (TREE_CODE (val) != INTEGER_CST)
2072     return true;
2073
2074   return tree_int_cst_equal (val, min_or_max_val) == 1;
2075 }
2076
2077 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2078    If REVERSE is true, minimum value is taken as maximum value.  */
2079
2080 static inline bool
2081 can_equal_min_val_p (tree val, tree type, bool reverse)
2082 {
2083   return can_equal_min_or_max_val_p (val, type, reverse);
2084 }
2085
2086 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2087    If REVERSE is true, maximum value is taken as minimum value.  */
2088
2089 static inline bool
2090 can_equal_max_val_p (tree val, tree type, bool reverse)
2091 {
2092   return can_equal_min_or_max_val_p (val, type, !reverse);
2093 }
2094
2095 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2096    to a GCC tree, which is returned.  */
2097
2098 static tree
2099 Loop_Statement_to_gnu (Node_Id gnat_node)
2100 {
2101   const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2102   tree gnu_loop_stmt = build5 (LOOP_STMT, void_type_node, NULL_TREE,
2103                                NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE);
2104   tree gnu_loop_label = create_artificial_label (input_location);
2105   tree gnu_loop_var = NULL_TREE, gnu_cond_expr = NULL_TREE;
2106   tree gnu_result;
2107
2108   /* Set location information for statement and end label.  */
2109   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2110   Sloc_to_locus (Sloc (End_Label (gnat_node)),
2111                  &DECL_SOURCE_LOCATION (gnu_loop_label));
2112   LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2113
2114   /* Save the end label of this LOOP_STMT in a stack so that a corresponding
2115      N_Exit_Statement can find it.  */
2116   push_stack (&gnu_loop_label_stack, NULL_TREE, gnu_loop_label);
2117
2118   /* Set the condition under which the loop must keep going.
2119      For the case "LOOP .... END LOOP;" the condition is always true.  */
2120   if (No (gnat_iter_scheme))
2121     ;
2122
2123   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2124   else if (Present (Condition (gnat_iter_scheme)))
2125     LOOP_STMT_COND (gnu_loop_stmt)
2126       = gnat_to_gnu (Condition (gnat_iter_scheme));
2127
2128   /* Otherwise we have an iteration scheme and the condition is given by the
2129      bounds of the subtype of the iteration variable.  */
2130   else
2131     {
2132       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2133       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2134       Entity_Id gnat_type = Etype (gnat_loop_var);
2135       tree gnu_type = get_unpadded_type (gnat_type);
2136       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2137       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2138       tree gnu_base_type = get_base_type (gnu_type);
2139       tree gnu_first, gnu_last, gnu_limit, gnu_test;
2140       enum tree_code update_code, test_code;
2141
2142       /* We must disable modulo reduction for the iteration variable, if any,
2143          in order for the loop comparison to be effective.  */
2144       if (reverse)
2145         {
2146           gnu_first = gnu_high;
2147           gnu_last = gnu_low;
2148           update_code = MINUS_NOMOD_EXPR;
2149           test_code = GE_EXPR;
2150           gnu_limit = TYPE_MIN_VALUE (gnu_base_type);
2151         }
2152       else
2153         {
2154           gnu_first = gnu_low;
2155           gnu_last = gnu_high;
2156           update_code = PLUS_NOMOD_EXPR;
2157           test_code = LE_EXPR;
2158           gnu_limit = TYPE_MAX_VALUE (gnu_base_type);
2159         }
2160
2161       /* We know that the iteration variable will not overflow if GNU_LAST is
2162          a constant and is not equal to GNU_LIMIT.  If it might overflow, we
2163          have to turn the limit test into an inequality test and move it to
2164          the end of the loop; as a consequence, we also have to test for an
2165          empty loop before entering it.  */
2166       if (TREE_CODE (gnu_last) != INTEGER_CST
2167           || TREE_CODE (gnu_limit) != INTEGER_CST
2168           || tree_int_cst_equal (gnu_last, gnu_limit))
2169         {
2170           test_code = NE_EXPR;
2171           gnu_cond_expr
2172             = build3 (COND_EXPR, void_type_node,
2173                       build_binary_op (LE_EXPR, boolean_type_node,
2174                                        gnu_low, gnu_high),
2175                       NULL_TREE, alloc_stmt_list ());
2176           set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2177           test_code = NE_EXPR;
2178         }
2179
2180       /* Open a new nesting level that will surround the loop to declare the
2181          iteration variable.  */
2182       start_stmt_group ();
2183       gnat_pushlevel ();
2184
2185       /* Declare the iteration variable and set it to its initial value.  */
2186       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2187       if (DECL_BY_REF_P (gnu_loop_var))
2188         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2189
2190       /* Do all the arithmetics in the base type.  */
2191       gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2192
2193       /* Set either the top or bottom exit condition as appropriate depending
2194          on whether or not we know an overflow cannot occur.  */
2195       gnu_test = build_binary_op (test_code, integer_type_node, gnu_loop_var,
2196                                   gnu_last);
2197       if (gnu_cond_expr)
2198         LOOP_STMT_BOT_COND (gnu_loop_stmt) = gnu_test;
2199       else
2200         LOOP_STMT_TOP_COND (gnu_loop_stmt) = gnu_test;
2201
2202       /* Set either the top or bottom update statement and give it the source
2203          location of the iteration for better coverage info.  */
2204       LOOP_STMT_UPDATE (gnu_loop_stmt)
2205         = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2206                            build_binary_op (update_code, gnu_base_type,
2207                                             gnu_loop_var, gnu_one_node));
2208       set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
2209                                    gnat_iter_scheme);
2210     }
2211
2212   /* If the loop was named, have the name point to this loop.  In this case,
2213      the association is not a DECL node, but the end label of the loop.  */
2214   if (Present (Identifier (gnat_node)))
2215     save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2216
2217   /* Make the loop body into its own block, so any allocated storage will be
2218      released every iteration.  This is needed for stack allocation.  */
2219   LOOP_STMT_BODY (gnu_loop_stmt)
2220     = build_stmt_group (Statements (gnat_node), true);
2221   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2222
2223   /* If we declared a variable, then we are in a statement group for that
2224      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
2225   if (gnu_loop_var)
2226     {
2227       add_stmt (gnu_loop_stmt);
2228       gnat_poplevel ();
2229       gnu_loop_stmt = end_stmt_group ();
2230     }
2231
2232   /* If we have an outer COND_EXPR, that's our result and this loop is its
2233      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2234   if (gnu_cond_expr)
2235     {
2236       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2237       gnu_result = gnu_cond_expr;
2238       recalculate_side_effects (gnu_cond_expr);
2239     }
2240   else
2241     gnu_result = gnu_loop_stmt;
2242
2243   pop_stack (&gnu_loop_label_stack);
2244
2245   return gnu_result;
2246 }
2247 \f
2248 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2249    handler for the current function.  */
2250
2251 /* This is implemented by issuing a call to the appropriate VMS specific
2252    builtin.  To avoid having VMS specific sections in the global gigi decls
2253    array, we maintain the decls of interest here.  We can't declare them
2254    inside the function because we must mark them never to be GC'd, which we
2255    can only do at the global level.  */
2256
2257 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2258 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2259
2260 static void
2261 establish_gnat_vms_condition_handler (void)
2262 {
2263   tree establish_stmt;
2264
2265   /* Elaborate the required decls on the first call.  Check on the decl for
2266      the gnat condition handler to decide, as this is one we create so we are
2267      sure that it will be non null on subsequent calls.  The builtin decl is
2268      looked up so remains null on targets where it is not implemented yet.  */
2269   if (gnat_vms_condition_handler_decl == NULL_TREE)
2270     {
2271       vms_builtin_establish_handler_decl
2272         = builtin_decl_for
2273           (get_identifier ("__builtin_establish_vms_condition_handler"));
2274
2275       gnat_vms_condition_handler_decl
2276         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2277                                NULL_TREE,
2278                                build_function_type_list (boolean_type_node,
2279                                                          ptr_void_type_node,
2280                                                          ptr_void_type_node,
2281                                                          NULL_TREE),
2282                                NULL_TREE, 0, 1, 1, 0, Empty);
2283
2284       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2285       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2286     }
2287
2288   /* Do nothing if the establish builtin is not available, which might happen
2289      on targets where the facility is not implemented.  */
2290   if (vms_builtin_establish_handler_decl == NULL_TREE)
2291     return;
2292
2293   establish_stmt
2294     = build_call_1_expr (vms_builtin_establish_handler_decl,
2295                          build_unary_op
2296                          (ADDR_EXPR, NULL_TREE,
2297                           gnat_vms_condition_handler_decl));
2298
2299   add_stmt (establish_stmt);
2300 }
2301 \f
2302 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
2303    don't return anything.  */
2304
2305 static void
2306 Subprogram_Body_to_gnu (Node_Id gnat_node)
2307 {
2308   /* Defining identifier of a parameter to the subprogram.  */
2309   Entity_Id gnat_param;
2310   /* The defining identifier for the subprogram body. Note that if a
2311      specification has appeared before for this body, then the identifier
2312      occurring in that specification will also be a defining identifier and all
2313      the calls to this subprogram will point to that specification.  */
2314   Entity_Id gnat_subprog_id
2315     = (Present (Corresponding_Spec (gnat_node))
2316        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2317   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
2318   tree gnu_subprog_decl;
2319   /* Its RESULT_DECL node.  */
2320   tree gnu_result_decl;
2321   /* The FUNCTION_TYPE node corresponding to the subprogram spec.  */
2322   tree gnu_subprog_type;
2323   tree gnu_cico_list;
2324   tree gnu_result;
2325   VEC(parm_attr,gc) *cache;
2326
2327   /* If this is a generic object or if it has been eliminated,
2328      ignore it.  */
2329   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2330       || Ekind (gnat_subprog_id) == E_Generic_Function
2331       || Is_Eliminated (gnat_subprog_id))
2332     return;
2333
2334   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
2335      the already-elaborated tree node.  However, if this subprogram had its
2336      elaboration deferred, we will already have made a tree node for it.  So
2337      treat it as not being defined in that case.  Such a subprogram cannot
2338      have an address clause or a freeze node, so this test is safe, though it
2339      does disable some otherwise-useful error checking.  */
2340   gnu_subprog_decl
2341     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2342                           Acts_As_Spec (gnat_node)
2343                           && !present_gnu_tree (gnat_subprog_id));
2344   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
2345   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2346
2347   /* If the function returns by invisible reference, make it explicit in the
2348      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.  */
2349   if (TREE_ADDRESSABLE (gnu_subprog_type))
2350     {
2351       TREE_TYPE (gnu_result_decl)
2352         = build_reference_type (TREE_TYPE (gnu_result_decl));
2353       relayout_decl (gnu_result_decl);
2354     }
2355
2356   /* Propagate the debug mode.  */
2357   if (!Needs_Debug_Info (gnat_subprog_id))
2358     DECL_IGNORED_P (gnu_subprog_decl) = 1;
2359
2360   /* Set the line number in the decl to correspond to that of the body so that
2361      the line number notes are written correctly.  */
2362   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
2363
2364   /* Initialize the information structure for the function.  */
2365   allocate_struct_function (gnu_subprog_decl, false);
2366   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
2367     = GGC_CNEW (struct language_function);
2368   set_cfun (NULL);
2369
2370   begin_subprog_body (gnu_subprog_decl);
2371
2372   /* If there are Out parameters, we need to ensure that the return statement
2373      properly copies them out.  We do this by making a new block and converting
2374      any inner return into a goto to a label at the end of the block.  */
2375   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2376   push_stack (&gnu_return_label_stack, NULL_TREE,
2377               gnu_cico_list ? create_artificial_label (input_location)
2378               : NULL_TREE);
2379
2380   /* Get a tree corresponding to the code for the subprogram.  */
2381   start_stmt_group ();
2382   gnat_pushlevel ();
2383
2384   /* See if there are any parameters for which we don't yet have GCC entities.
2385      These must be for Out parameters for which we will be making VAR_DECL
2386      nodes here.  Fill them in to TYPE_CI_CO_LIST, which must contain the empty
2387      entry as well.  We can match up the entries because TYPE_CI_CO_LIST is in
2388      the order of the parameters.  */
2389   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2390        Present (gnat_param);
2391        gnat_param = Next_Formal_With_Extras (gnat_param))
2392     if (!present_gnu_tree (gnat_param))
2393       {
2394         /* Skip any entries that have been already filled in; they must
2395            correspond to In Out parameters.  */
2396         for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
2397              gnu_cico_list = TREE_CHAIN (gnu_cico_list))
2398           ;
2399
2400         /* Do any needed references for padded types.  */
2401         TREE_VALUE (gnu_cico_list)
2402           = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
2403                      gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2404       }
2405
2406   /* On VMS, establish our condition handler to possibly turn a condition into
2407      the corresponding exception if the subprogram has a foreign convention or
2408      is exported.
2409
2410      To ensure proper execution of local finalizations on condition instances,
2411      we must turn a condition into the corresponding exception even if there
2412      is no applicable Ada handler, and need at least one condition handler per
2413      possible call chain involving GNAT code.  OTOH, establishing the handler
2414      has a cost so we want to minimize the number of subprograms into which
2415      this happens.  The foreign or exported condition is expected to satisfy
2416      all the constraints.  */
2417   if (TARGET_ABI_OPEN_VMS
2418       && (Has_Foreign_Convention (gnat_subprog_id)
2419           || Is_Exported (gnat_subprog_id)))
2420     establish_gnat_vms_condition_handler ();
2421
2422   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
2423
2424   /* Generate the code of the subprogram itself.  A return statement will be
2425      present and any Out parameters will be handled there.  */
2426   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
2427   gnat_poplevel ();
2428   gnu_result = end_stmt_group ();
2429
2430   /* If we populated the parameter attributes cache, we need to make sure
2431      that the cached expressions are evaluated on all possible paths.  */
2432   cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
2433   if (cache)
2434     {
2435       struct parm_attr_d *pa;
2436       int i;
2437
2438       start_stmt_group ();
2439
2440       for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
2441         {
2442           if (pa->first)
2443             add_stmt_with_node (pa->first, gnat_node);
2444           if (pa->last)
2445             add_stmt_with_node (pa->last, gnat_node);
2446           if (pa->length)
2447             add_stmt_with_node (pa->length, gnat_node);
2448         }
2449
2450       add_stmt (gnu_result);
2451       gnu_result = end_stmt_group ();
2452     }
2453
2454     /* If we are dealing with a return from an Ada procedure with parameters
2455        passed by copy-in/copy-out, we need to return a record containing the
2456        final values of these parameters.  If the list contains only one entry,
2457        return just that entry though.
2458
2459        For a full description of the copy-in/copy-out parameter mechanism, see
2460        the part of the gnat_to_gnu_entity routine dealing with the translation
2461        of subprograms.
2462
2463        We need to make a block that contains the definition of that label and
2464        the copying of the return value.  It first contains the function, then
2465        the label and copy statement.  */
2466   if (TREE_VALUE (gnu_return_label_stack))
2467     {
2468       tree gnu_retval;
2469
2470       start_stmt_group ();
2471       gnat_pushlevel ();
2472       add_stmt (gnu_result);
2473       add_stmt (build1 (LABEL_EXPR, void_type_node,
2474                         TREE_VALUE (gnu_return_label_stack)));
2475
2476       gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2477       if (list_length (gnu_cico_list) == 1)
2478         gnu_retval = TREE_VALUE (gnu_cico_list);
2479       else
2480         gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2481                                              gnu_cico_list);
2482
2483       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
2484                           End_Label (Handled_Statement_Sequence (gnat_node)));
2485       gnat_poplevel ();
2486       gnu_result = end_stmt_group ();
2487     }
2488
2489   pop_stack (&gnu_return_label_stack);
2490
2491   /* Set the end location.  */
2492   Sloc_to_locus
2493     ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
2494       ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
2495       : Sloc (gnat_node)),
2496      &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
2497
2498   end_subprog_body (gnu_result);
2499
2500   /* Finally annotate the parameters and disconnect the trees for parameters
2501      that we have turned into variables since they are now unusable.  */
2502   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2503        Present (gnat_param);
2504        gnat_param = Next_Formal_With_Extras (gnat_param))
2505     {
2506       tree gnu_param = get_gnu_tree (gnat_param);
2507       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
2508                        DECL_BY_REF_P (gnu_param));
2509       if (TREE_CODE (gnu_param) == VAR_DECL)
2510         save_gnu_tree (gnat_param, NULL_TREE, false);
2511     }
2512
2513   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2514     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2515
2516   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2517 }
2518 \f
2519 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2520    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2521    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2522    If GNU_TARGET is non-null, this must be a function call on the RHS of a
2523    N_Assignment_Statement and the result is to be placed into that object.  */
2524
2525 static tree
2526 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2527 {
2528   /* The GCC node corresponding to the GNAT subprogram name.  This can either
2529      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2530      or an indirect reference expression (an INDIRECT_REF node) pointing to a
2531      subprogram.  */
2532   tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
2533   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2534   tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
2535   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
2536   Entity_Id gnat_formal;
2537   Node_Id gnat_actual;
2538   VEC(tree,gc) *gnu_actual_vec = NULL;
2539   tree gnu_name_list = NULL_TREE;
2540   tree gnu_before_list = NULL_TREE;
2541   tree gnu_after_list = NULL_TREE;
2542   tree gnu_call;
2543   bool went_into_elab_proc = false;
2544
2545   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2546
2547   /* If we are calling a stubbed function, raise Program_Error, but Elaborate
2548      all our args first.  */
2549   if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
2550     {
2551       tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
2552                                          gnat_node, N_Raise_Program_Error);
2553
2554       for (gnat_actual = First_Actual (gnat_node);
2555            Present (gnat_actual);
2556            gnat_actual = Next_Actual (gnat_actual))
2557         add_stmt (gnat_to_gnu (gnat_actual));
2558
2559       if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
2560         {
2561           *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
2562           return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr);
2563         }
2564
2565       return call_expr;
2566     }
2567
2568   /* The only way we can be making a call via an access type is if Name is an
2569      explicit dereference.  In that case, get the list of formal args from the
2570      type the access type is pointing to.  Otherwise, get the formals from the
2571      entity being called.  */
2572   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2573     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2574   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2575     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2576     gnat_formal = Empty;
2577   else
2578     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2579
2580   /* If we are translating a statement, open a new nesting level that will
2581      surround it to declare the temporaries created for the call.  */
2582   if (Nkind (gnat_node) == N_Procedure_Call_Statement || gnu_target)
2583     {
2584       start_stmt_group ();
2585       gnat_pushlevel ();
2586     }
2587
2588   /* The lifetime of the temporaries created for the call ends with the call
2589      so we can give them the scope of the elaboration routine at top level.  */
2590   else if (!current_function_decl)
2591     {
2592       current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
2593       went_into_elab_proc = true;
2594     }
2595
2596   /* Create the list of the actual parameters as GCC expects it, namely a
2597      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
2598      is an expression and the TREE_PURPOSE field is null.  But skip Out
2599      parameters not passed by reference and that need not be copied in.  */
2600   for (gnat_actual = First_Actual (gnat_node);
2601        Present (gnat_actual);
2602        gnat_formal = Next_Formal_With_Extras (gnat_formal),
2603        gnat_actual = Next_Actual (gnat_actual))
2604     {
2605       tree gnu_formal = present_gnu_tree (gnat_formal)
2606                         ? get_gnu_tree (gnat_formal) : NULL_TREE;
2607       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2608       /* In the Out or In Out case, we must suppress conversions that yield
2609          an lvalue but can nevertheless cause the creation of a temporary,
2610          because we need the real object in this case, either to pass its
2611          address if it's passed by reference or as target of the back copy
2612          done after the call if it uses the copy-in copy-out mechanism.
2613          We do it in the In case too, except for an unchecked conversion
2614          because it alone can cause the actual to be misaligned and the
2615          addressability test is applied to the real object.  */
2616       bool suppress_type_conversion
2617         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2618             && Ekind (gnat_formal) != E_In_Parameter)
2619            || (Nkind (gnat_actual) == N_Type_Conversion
2620                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2621       Node_Id gnat_name = suppress_type_conversion
2622                           ? Expression (gnat_actual) : gnat_actual;
2623       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2624       tree gnu_actual;
2625
2626       /* If it's possible we may need to use this expression twice, make sure
2627          that any side-effects are handled via SAVE_EXPRs; likewise if we need
2628          to force side-effects before the call.
2629          ??? This is more conservative than we need since we don't need to do
2630          this for pass-by-ref with no conversion.  */
2631       if (Ekind (gnat_formal) != E_In_Parameter)
2632         gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
2633
2634       /* If we are passing a non-addressable parameter by reference, pass the
2635          address of a copy.  In the Out or In Out case, set up to copy back
2636          out after the call.  */
2637       if (gnu_formal
2638           && (DECL_BY_REF_P (gnu_formal)
2639               || (TREE_CODE (gnu_formal) == PARM_DECL
2640                   && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2641                       || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2642           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2643           && !addressable_p (gnu_name, gnu_name_type))
2644         {
2645           tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
2646
2647           /* Do not issue warnings for CONSTRUCTORs since this is not a copy
2648              but sort of an instantiation for them.  */
2649           if (TREE_CODE (gnu_name) == CONSTRUCTOR)
2650             ;
2651
2652           /* If the type is passed by reference, a copy is not allowed.  */
2653           else if (TREE_ADDRESSABLE (gnu_formal_type))
2654             post_error ("misaligned actual cannot be passed by reference",
2655                         gnat_actual);
2656
2657           /* For users of Starlet we issue a warning because the interface
2658              apparently assumes that by-ref parameters outlive the procedure
2659              invocation.  The code still will not work as intended, but we
2660              cannot do much better since low-level parts of the back-end
2661              would allocate temporaries at will because of the misalignment
2662              if we did not do so here.  */
2663           else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2664             {
2665               post_error
2666                 ("?possible violation of implicit assumption", gnat_actual);
2667               post_error_ne
2668                 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
2669                  Entity (Name (gnat_node)));
2670               post_error_ne ("?because of misalignment of &", gnat_actual,
2671                              gnat_formal);
2672             }
2673
2674           /* If the actual type of the object is already the nominal type,
2675              we have nothing to do, except if the size is self-referential
2676              in which case we'll remove the unpadding below.  */
2677           if (TREE_TYPE (gnu_name) == gnu_name_type
2678               && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
2679             ;
2680
2681           /* Otherwise remove the unpadding from all the objects.  */
2682           else if (TREE_CODE (gnu_name) == COMPONENT_REF
2683                    && TYPE_IS_PADDING_P
2684                       (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
2685             gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
2686
2687           /* Otherwise convert to the nominal type of the object if needed.
2688              There are several cases in which we need to make the temporary
2689              using this type instead of the actual type of the object when
2690              they are distinct, because the expectations of the callee would
2691              otherwise not be met:
2692                - if it's a justified modular type,
2693                - if the actual type is a smaller form of it,
2694                - if it's a smaller form of the actual type.  */
2695           else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
2696                     && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
2697                         || smaller_form_type_p (TREE_TYPE (gnu_name),
2698                                                 gnu_name_type)))
2699                    || (INTEGRAL_TYPE_P (gnu_name_type)
2700                        && smaller_form_type_p (gnu_name_type,
2701                                                TREE_TYPE (gnu_name))))
2702             gnu_name = convert (gnu_name_type, gnu_name);
2703
2704           /* Create an explicit temporary holding the copy.  This ensures that
2705              its lifetime is as narrow as possible around a statement.  */
2706           gnu_temp = create_var_decl (create_tmp_var_name ("A"), NULL_TREE,
2707                                       TREE_TYPE (gnu_name), NULL_TREE, false,
2708                                       false, false, false, NULL, Empty);
2709           DECL_ARTIFICIAL (gnu_temp) = 1;
2710           DECL_IGNORED_P (gnu_temp) = 1;
2711
2712           /* But initialize it on the fly like for an implicit temporary as
2713              we aren't necessarily dealing with a statement.  */
2714           gnu_stmt
2715             = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_name);
2716           set_expr_location_from_node (gnu_stmt, gnat_actual);
2717
2718           /* From now on, the real object is the temporary.  */
2719           gnu_name = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_name), gnu_stmt,
2720                              gnu_temp);
2721
2722           /* Set up to move the copy back to the original if needed.  */
2723           if (Ekind (gnat_formal) != E_In_Parameter)
2724             {
2725               gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
2726                                           gnu_temp);
2727               set_expr_location_from_node (gnu_stmt, gnat_node);
2728               append_to_statement_list (gnu_stmt, &gnu_after_list);
2729             }
2730         }
2731
2732       /* Start from the real object and build the actual.  */
2733       gnu_actual = gnu_name;
2734
2735       /* If this was a procedure call, we may not have removed any padding.
2736          So do it here for the part we will use as an input, if any.  */
2737       if (Ekind (gnat_formal) != E_Out_Parameter
2738           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2739         gnu_actual
2740           = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
2741
2742       /* Put back the conversion we suppressed above in the computation of the
2743          real object.  And even if we didn't suppress any conversion there, we
2744          may have suppressed a conversion to the Etype of the actual earlier,
2745          since the parent is a procedure call, so put it back here.  */
2746       if (suppress_type_conversion
2747           && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2748         gnu_actual
2749           = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2750                                gnu_actual, No_Truncation (gnat_actual));
2751       else
2752         gnu_actual
2753           = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
2754
2755       /* Make sure that the actual is in range of the formal's type.  */
2756       if (Ekind (gnat_formal) != E_Out_Parameter
2757           && Do_Range_Check (gnat_actual))
2758         gnu_actual
2759           = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
2760
2761       /* Unless this is an In parameter, we must remove any justified modular
2762          building from GNU_NAME to get an lvalue.  */
2763       if (Ekind (gnat_formal) != E_In_Parameter
2764           && TREE_CODE (gnu_name) == CONSTRUCTOR
2765           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2766           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2767         gnu_name
2768           = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
2769
2770       /* If we have not saved a GCC object for the formal, it means it is an
2771          Out parameter not passed by reference and that need not be copied in.
2772          Otherwise, first see if the parameter is passed by reference.  */
2773       if (gnu_formal
2774           && TREE_CODE (gnu_formal) == PARM_DECL
2775           && DECL_BY_REF_P (gnu_formal))
2776         {
2777           if (Ekind (gnat_formal) != E_In_Parameter)
2778             {
2779               /* In Out or Out parameters passed by reference don't use the
2780                  copy-in copy-out mechanism so the address of the real object
2781                  must be passed to the function.  */
2782               gnu_actual = gnu_name;
2783
2784               /* If we have a padded type, be sure we've removed padding.  */
2785               if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2786                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2787                                       gnu_actual);
2788
2789               /* If we have the constructed subtype of an aliased object
2790                  with an unconstrained nominal subtype, the type of the
2791                  actual includes the template, although it is formally
2792                  constrained.  So we need to convert it back to the real
2793                  constructed subtype to retrieve the constrained part
2794                  and takes its address.  */
2795               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2796                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
2797                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
2798                   && Is_Array_Type (Etype (gnat_actual)))
2799                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2800                                       gnu_actual);
2801             }
2802
2803           /* There is no need to convert the actual to the formal's type before
2804              taking its address.  The only exception is for unconstrained array
2805              types because of the way we build fat pointers.  */
2806           else if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
2807             gnu_actual = convert (gnu_formal_type, gnu_actual);
2808
2809           /* The symmetry of the paths to the type of an entity is broken here
2810              since arguments don't know that they will be passed by ref.  */
2811           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2812           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2813         }
2814       else if (gnu_formal
2815                && TREE_CODE (gnu_formal) == PARM_DECL
2816                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
2817         {
2818           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2819           gnu_actual = maybe_implicit_deref (gnu_actual);
2820           gnu_actual = maybe_unconstrained_array (gnu_actual);
2821
2822           if (TYPE_IS_PADDING_P (gnu_formal_type))
2823             {
2824               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2825               gnu_actual = convert (gnu_formal_type, gnu_actual);
2826             }
2827
2828           /* Take the address of the object and convert to the proper pointer
2829              type.  We'd like to actually compute the address of the beginning
2830              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2831              possibility that the ARRAY_REF might return a constant and we'd be
2832              getting the wrong address.  Neither approach is exactly correct,
2833              but this is the most likely to work in all cases.  */
2834           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2835         }
2836       else if (gnu_formal
2837                && TREE_CODE (gnu_formal) == PARM_DECL
2838                && DECL_BY_DESCRIPTOR_P (gnu_formal))
2839         {
2840           gnu_actual = convert (gnu_formal_type, gnu_actual);
2841
2842           /* If this is 'Null_Parameter, pass a zero descriptor.  */
2843           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2844                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2845               && TREE_PRIVATE (gnu_actual))
2846             gnu_actual
2847               = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
2848           else
2849             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
2850                                          fill_vms_descriptor (gnu_actual,
2851                                                               gnat_formal,
2852                                                               gnat_actual));
2853         }
2854       else
2855         {
2856           tree gnu_size;
2857
2858           if (Ekind (gnat_formal) != E_In_Parameter)
2859             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
2860
2861           if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
2862             {
2863               /* Make sure side-effects are evaluated before the call.  */
2864               if (TREE_SIDE_EFFECTS (gnu_name))
2865                 append_to_statement_list (gnu_name, &gnu_before_list);
2866               continue;
2867             }
2868
2869           gnu_actual = convert (gnu_formal_type, gnu_actual);
2870
2871           /* If this is 'Null_Parameter, pass a zero even though we are
2872              dereferencing it.  */
2873           if (TREE_CODE (gnu_actual) == INDIRECT_REF
2874               && TREE_PRIVATE (gnu_actual)
2875               && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
2876               && TREE_CODE (gnu_size) == INTEGER_CST
2877               && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
2878             gnu_actual
2879               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
2880                                    convert (gnat_type_for_size
2881                                             (TREE_INT_CST_LOW (gnu_size), 1),
2882                                             integer_zero_node),
2883                                    false);
2884           else
2885             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
2886         }
2887
2888       VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual);
2889     }
2890
2891   gnu_call = build_call_list (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr,
2892                               nreverse (gnu_actual_list));
2893   set_expr_location_from_node (gnu_call, gnat_node);
2894
2895   /* If it's a function call, the result is the call expression unless a target
2896      is specified, in which case we copy the result into the target and return
2897      the assignment statement.  */
2898   if (Nkind (gnat_node) == N_Function_Call)
2899     {
2900       tree gnu_result = gnu_call;
2901
2902       /* If the function returns an unconstrained array or by direct reference,
2903          we have to dereference the pointer.  */
2904       if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
2905           || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
2906         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2907
2908       if (gnu_target)
2909         {
2910           Node_Id gnat_parent = Parent (gnat_node);
2911           enum tree_code op_code;
2912
2913           /* If range check is needed, emit code to generate it.  */
2914           if (Do_Range_Check (gnat_node))
2915             gnu_result
2916               = emit_range_check (gnu_result, Etype (Name (gnat_parent)),
2917                                   gnat_parent);
2918
2919           /* ??? If the return type has non-constant size, then force the
2920              return slot optimization as we would not be able to generate
2921              a temporary.  That's what has been done historically.  */
2922           if (TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_subprog_type))))
2923             op_code = MODIFY_EXPR;
2924           else
2925             op_code = INIT_EXPR;
2926
2927           gnu_result
2928             = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result);
2929           add_stmt_with_node (gnu_result, gnat_parent);
2930           gnat_poplevel ();
2931           gnu_result = end_stmt_group ();
2932         }
2933       else
2934         {
2935           if (went_into_elab_proc)
2936             current_function_decl = NULL_TREE;
2937           *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
2938         }
2939
2940       return gnu_result;
2941     }
2942
2943   /* If this is the case where the GNAT tree contains a procedure call but the
2944      Ada procedure has copy-in/copy-out parameters, then the special parameter
2945      passing mechanism must be used.  */
2946   if (TYPE_CI_CO_LIST (gnu_subprog_type))
2947     {
2948       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
2949          copy-out parameters.  */
2950       tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2951       const int length = list_length (gnu_cico_list);
2952
2953       if (length > 1)
2954         {
2955           tree gnu_temp, gnu_stmt;
2956
2957           /* The call sequence must contain one and only one call, even though
2958              the function is pure.  Save the result into a temporary.  */
2959           gnu_temp = create_var_decl (create_tmp_var_name ("R"), NULL_TREE,
2960                                       TREE_TYPE (gnu_call), NULL_TREE, false,
2961                                       false, false, false, NULL, Empty);
2962           DECL_ARTIFICIAL (gnu_temp) = 1;
2963           DECL_IGNORED_P (gnu_temp) = 1;
2964
2965           gnu_stmt
2966             = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_call);
2967           set_expr_location_from_node (gnu_stmt, gnat_node);
2968
2969           /* Add the call statement to the list and start from its result.  */
2970           append_to_statement_list (gnu_stmt, &gnu_before_list);
2971           gnu_call = gnu_temp;
2972
2973           gnu_name_list = nreverse (gnu_name_list);
2974         }
2975
2976       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2977         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2978       else
2979         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2980
2981       for (gnat_actual = First_Actual (gnat_node);
2982            Present (gnat_actual);
2983            gnat_formal = Next_Formal_With_Extras (gnat_formal),
2984            gnat_actual = Next_Actual (gnat_actual))
2985         /* If we are dealing with a copy in copy out parameter, we must
2986            retrieve its value from the record returned in the call.  */
2987         if (!(present_gnu_tree (gnat_formal)
2988               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2989               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2990                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2991                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2992                            || (DECL_BY_DESCRIPTOR_P
2993                                (get_gnu_tree (gnat_formal))))))))
2994             && Ekind (gnat_formal) != E_In_Parameter)
2995           {
2996             /* Get the value to assign to this Out or In Out parameter.  It is
2997                either the result of the function if there is only a single such
2998                parameter or the appropriate field from the record returned.  */
2999             tree gnu_result
3000               = length == 1
3001                 ? gnu_call
3002                 : build_component_ref (gnu_call, NULL_TREE,
3003                                        TREE_PURPOSE (gnu_cico_list), false);
3004
3005             /* If the actual is a conversion, get the inner expression, which
3006                will be the real destination, and convert the result to the
3007                type of the actual parameter.  */
3008             tree gnu_actual
3009               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3010
3011             /* If the result is a padded type, remove the padding.  */
3012             if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3013               gnu_result
3014                 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
3015                            gnu_result);
3016
3017             /* If the actual is a type conversion, the real target object is
3018                denoted by the inner Expression and we need to convert the
3019                result to the associated type.
3020                We also need to convert our gnu assignment target to this type
3021                if the corresponding GNU_NAME was constructed from the GNAT
3022                conversion node and not from the inner Expression.  */
3023             if (Nkind (gnat_actual) == N_Type_Conversion)
3024               {
3025                 gnu_result
3026                   = convert_with_check
3027                     (Etype (Expression (gnat_actual)), gnu_result,
3028                      Do_Overflow_Check (gnat_actual),
3029                      Do_Range_Check (Expression (gnat_actual)),
3030                      Float_Truncate (gnat_actual), gnat_actual);
3031
3032                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
3033                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
3034               }
3035
3036             /* Unchecked conversions as actuals for Out parameters are not
3037                allowed in user code because they are not variables, but do
3038                occur in front-end expansions.  The associated GNU_NAME is
3039                always obtained from the inner expression in such cases.  */
3040             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
3041               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
3042                                               gnu_result,
3043                                               No_Truncation (gnat_actual));
3044             else
3045               {
3046                 if (Do_Range_Check (gnat_actual))
3047                   gnu_result
3048                     = emit_range_check (gnu_result, Etype (gnat_actual),
3049                                         gnat_actual);
3050
3051                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
3052                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
3053                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
3054               }
3055
3056             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3057                                           gnu_actual, gnu_result);
3058             set_expr_location_from_node (gnu_result, gnat_node);
3059             append_to_statement_list (gnu_result, &gnu_before_list);
3060             gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3061             gnu_name_list = TREE_CHAIN (gnu_name_list);
3062           }
3063     }
3064   else
3065     append_to_statement_list (gnu_call, &gnu_before_list);
3066
3067   append_to_statement_list (gnu_after_list, &gnu_before_list);
3068
3069   add_stmt (gnu_before_list);
3070   gnat_poplevel ();
3071   return end_stmt_group ();
3072 }
3073 \f
3074 /* Subroutine of gnat_to_gnu to translate gnat_node, an
3075    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
3076
3077 static tree
3078 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
3079 {
3080   tree gnu_jmpsave_decl = NULL_TREE;
3081   tree gnu_jmpbuf_decl = NULL_TREE;
3082   /* If just annotating, ignore all EH and cleanups.  */
3083   bool gcc_zcx = (!type_annotate_only
3084                   && Present (Exception_Handlers (gnat_node))
3085                   && Exception_Mechanism == Back_End_Exceptions);
3086   bool setjmp_longjmp
3087     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
3088        && Exception_Mechanism == Setjmp_Longjmp);
3089   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
3090   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
3091   tree gnu_inner_block; /* The statement(s) for the block itself.  */
3092   tree gnu_result;
3093   tree gnu_expr;
3094   Node_Id gnat_temp;
3095
3096   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
3097      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
3098      add_cleanup, and when we leave the binding, end_stmt_group will create
3099      the TRY_FINALLY_EXPR.
3100
3101      ??? The region level calls down there have been specifically put in place
3102      for a ZCX context and currently the order in which things are emitted
3103      (region/handlers) is different from the SJLJ case. Instead of putting
3104      other calls with different conditions at other places for the SJLJ case,
3105      it seems cleaner to reorder things for the SJLJ case and generalize the
3106      condition to make it not ZCX specific.
3107
3108      If there are any exceptions or cleanup processing involved, we need an
3109      outer statement group (for Setjmp_Longjmp) and binding level.  */
3110   if (binding_for_block)
3111     {
3112       start_stmt_group ();
3113       gnat_pushlevel ();
3114     }
3115
3116   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
3117      area for address of previous buffer.  Do this first since we need to have
3118      the setjmp buf known for any decls in this block.  */
3119   if (setjmp_longjmp)
3120     {
3121       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
3122                                           NULL_TREE, jmpbuf_ptr_type,
3123                                           build_call_0_expr (get_jmpbuf_decl),
3124                                           false, false, false, false, NULL,
3125                                           gnat_node);
3126       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
3127
3128       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
3129          because of the unstructured form of EH used by setjmp_longjmp, there
3130          might be forward edges going to __builtin_setjmp receivers on which
3131          it is uninitialized, although they will never be actually taken.  */
3132       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
3133       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
3134                                          NULL_TREE, jmpbuf_type,
3135                                          NULL_TREE, false, false, false, false,
3136                                          NULL, gnat_node);
3137       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
3138
3139       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
3140
3141       /* When we exit this block, restore the saved value.  */
3142       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
3143                    End_Label (gnat_node));
3144     }
3145
3146   /* If we are to call a function when exiting this block, add a cleanup
3147      to the binding level we made above.  Note that add_cleanup is FIFO
3148      so we must register this cleanup after the EH cleanup just above.  */
3149   if (at_end)
3150     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
3151                  End_Label (gnat_node));
3152
3153   /* Now build the tree for the declarations and statements inside this block.
3154      If this is SJLJ, set our jmp_buf as the current buffer.  */
3155   start_stmt_group ();
3156
3157   if (setjmp_longjmp)
3158     add_stmt (build_call_1_expr (set_jmpbuf_decl,
3159                                  build_unary_op (ADDR_EXPR, NULL_TREE,
3160                                                  gnu_jmpbuf_decl)));
3161
3162   if (Present (First_Real_Statement (gnat_node)))
3163     process_decls (Statements (gnat_node), Empty,
3164                    First_Real_Statement (gnat_node), true, true);
3165
3166   /* Generate code for each statement in the block.  */
3167   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3168                     ? First_Real_Statement (gnat_node)
3169                     : First (Statements (gnat_node)));
3170        Present (gnat_temp); gnat_temp = Next (gnat_temp))
3171     add_stmt (gnat_to_gnu (gnat_temp));
3172   gnu_inner_block = end_stmt_group ();
3173
3174   /* Now generate code for the two exception models, if either is relevant for
3175      this block.  */
3176   if (setjmp_longjmp)
3177     {
3178       tree *gnu_else_ptr = 0;
3179       tree gnu_handler;
3180
3181       /* Make a binding level for the exception handling declarations and code
3182          and set up gnu_except_ptr_stack for the handlers to use.  */
3183       start_stmt_group ();
3184       gnat_pushlevel ();
3185
3186       push_stack (&gnu_except_ptr_stack, NULL_TREE,
3187                   create_var_decl (get_identifier ("EXCEPT_PTR"),
3188                                    NULL_TREE,
3189                                    build_pointer_type (except_type_node),
3190                                    build_call_0_expr (get_excptr_decl), false,
3191                                    false, false, false, NULL, gnat_node));
3192
3193       /* Generate code for each handler. The N_Exception_Handler case does the
3194          real work and returns a COND_EXPR for each handler, which we chain
3195          together here.  */
3196       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3197            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
3198         {
3199           gnu_expr = gnat_to_gnu (gnat_temp);
3200
3201           /* If this is the first one, set it as the outer one. Otherwise,
3202              point the "else" part of the previous handler to us. Then point
3203              to our "else" part.  */
3204           if (!gnu_else_ptr)
3205             add_stmt (gnu_expr);
3206           else
3207             *gnu_else_ptr = gnu_expr;
3208
3209           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3210         }
3211
3212       /* If none of the exception handlers did anything, re-raise but do not
3213          defer abortion.  */
3214       gnu_expr = build_call_1_expr (raise_nodefer_decl,
3215                                     TREE_VALUE (gnu_except_ptr_stack));
3216       set_expr_location_from_node
3217         (gnu_expr,
3218          Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
3219
3220       if (gnu_else_ptr)
3221         *gnu_else_ptr = gnu_expr;
3222       else
3223         add_stmt (gnu_expr);
3224
3225       /* End the binding level dedicated to the exception handlers and get the
3226          whole statement group.  */
3227       pop_stack (&gnu_except_ptr_stack);
3228       gnat_poplevel ();
3229       gnu_handler = end_stmt_group ();
3230
3231       /* If the setjmp returns 1, we restore our incoming longjmp value and
3232          then check the handlers.  */
3233       start_stmt_group ();
3234       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
3235                                              gnu_jmpsave_decl),
3236                           gnat_node);
3237       add_stmt (gnu_handler);
3238       gnu_handler = end_stmt_group ();
3239
3240       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
3241       gnu_result = build3 (COND_EXPR, void_type_node,
3242                            (build_call_1_expr
3243                             (setjmp_decl,
3244                              build_unary_op (ADDR_EXPR, NULL_TREE,
3245                                              gnu_jmpbuf_decl))),
3246                            gnu_handler, gnu_inner_block);
3247     }
3248   else if (gcc_zcx)
3249     {
3250       tree gnu_handlers;
3251
3252       /* First make a block containing the handlers.  */
3253       start_stmt_group ();
3254       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3255            Present (gnat_temp);
3256            gnat_temp = Next_Non_Pragma (gnat_temp))
3257         add_stmt (gnat_to_gnu (gnat_temp));
3258       gnu_handlers = end_stmt_group ();
3259
3260       /* Now make the TRY_CATCH_EXPR for the block.  */
3261       gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
3262                            gnu_inner_block, gnu_handlers);
3263     }
3264   else
3265     gnu_result = gnu_inner_block;
3266
3267   /* Now close our outer block, if we had to make one.  */
3268   if (binding_for_block)
3269     {
3270       add_stmt (gnu_result);
3271       gnat_poplevel ();
3272       gnu_result = end_stmt_group ();
3273     }
3274
3275   return gnu_result;
3276 }
3277 \f
3278 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3279    to a GCC tree, which is returned.  This is the variant for Setjmp_Longjmp
3280    exception handling.  */
3281
3282 static tree
3283 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
3284 {
3285   /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
3286      an "if" statement to select the proper exceptions.  For "Others", exclude
3287      exceptions where Handled_By_Others is nonzero unless the All_Others flag
3288      is set. For "Non-ada", accept an exception if "Lang" is 'V'.  */
3289   tree gnu_choice = integer_zero_node;
3290   tree gnu_body = build_stmt_group (Statements (gnat_node), false);
3291   Node_Id gnat_temp;
3292
3293   for (gnat_temp = First (Exception_Choices (gnat_node));
3294        gnat_temp; gnat_temp = Next (gnat_temp))
3295     {
3296       tree this_choice;
3297
3298       if (Nkind (gnat_temp) == N_Others_Choice)
3299         {
3300           if (All_Others (gnat_temp))
3301             this_choice = integer_one_node;
3302           else
3303             this_choice
3304               = build_binary_op
3305                 (EQ_EXPR, boolean_type_node,
3306                  convert
3307                  (integer_type_node,
3308                   build_component_ref
3309                   (build_unary_op
3310                    (INDIRECT_REF, NULL_TREE,
3311                     TREE_VALUE (gnu_except_ptr_stack)),
3312                    get_identifier ("not_handled_by_others"), NULL_TREE,
3313                    false)),
3314                  integer_zero_node);
3315         }
3316
3317       else if (Nkind (gnat_temp) == N_Identifier
3318                || Nkind (gnat_temp) == N_Expanded_Name)
3319         {
3320           Entity_Id gnat_ex_id = Entity (gnat_temp);
3321           tree gnu_expr;
3322
3323           /* Exception may be a renaming. Recover original exception which is
3324              the one elaborated and registered.  */
3325           if (Present (Renamed_Object (gnat_ex_id)))
3326             gnat_ex_id = Renamed_Object (gnat_ex_id);
3327
3328           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3329
3330           this_choice
3331             = build_binary_op
3332               (EQ_EXPR, boolean_type_node, TREE_VALUE (gnu_except_ptr_stack),
3333                convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
3334                         build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3335
3336           /* If this is the distinguished exception "Non_Ada_Error" (and we are
3337              in VMS mode), also allow a non-Ada exception (a VMS condition) t
3338              match.  */
3339           if (Is_Non_Ada_Error (Entity (gnat_temp)))
3340             {
3341               tree gnu_comp
3342                 = build_component_ref
3343                   (build_unary_op (INDIRECT_REF, NULL_TREE,
3344                                    TREE_VALUE (gnu_except_ptr_stack)),
3345                    get_identifier ("lang"), NULL_TREE, false);
3346
3347               this_choice
3348                 = build_binary_op
3349                   (TRUTH_ORIF_EXPR, boolean_type_node,
3350                    build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp,
3351                                     build_int_cst (TREE_TYPE (gnu_comp), 'V')),
3352                    this_choice);
3353             }
3354         }
3355       else
3356         gcc_unreachable ();
3357
3358       gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
3359                                     gnu_choice, this_choice);
3360     }
3361
3362   return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
3363 }
3364 \f
3365 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3366    to a GCC tree, which is returned.  This is the variant for ZCX.  */
3367
3368 static tree
3369 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
3370 {
3371   tree gnu_etypes_list = NULL_TREE;
3372   tree gnu_expr;
3373   tree gnu_etype;
3374   tree gnu_current_exc_ptr;
3375   tree gnu_incoming_exc_ptr;
3376   Node_Id gnat_temp;
3377
3378   /* We build a TREE_LIST of nodes representing what exception types this
3379      handler can catch, with special cases for others and all others cases.
3380
3381      Each exception type is actually identified by a pointer to the exception
3382      id, or to a dummy object for "others" and "all others".  */
3383   for (gnat_temp = First (Exception_Choices (gnat_node));
3384        gnat_temp; gnat_temp = Next (gnat_temp))
3385     {
3386       if (Nkind (gnat_temp) == N_Others_Choice)
3387         {
3388           tree gnu_expr
3389             = All_Others (gnat_temp) ? all_others_decl : others_decl;
3390
3391           gnu_etype
3392             = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3393         }
3394       else if (Nkind (gnat_temp) == N_Identifier
3395                || Nkind (gnat_temp) == N_Expanded_Name)
3396         {
3397           Entity_Id gnat_ex_id = Entity (gnat_temp);
3398
3399           /* Exception may be a renaming. Recover original exception which is
3400              the one elaborated and registered.  */
3401           if (Present (Renamed_Object (gnat_ex_id)))
3402             gnat_ex_id = Renamed_Object (gnat_ex_id);
3403
3404           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3405           gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3406
3407           /* The Non_Ada_Error case for VMS exceptions is handled
3408              by the personality routine.  */
3409         }
3410       else
3411         gcc_unreachable ();
3412
3413       /* The GCC interface expects NULL to be passed for catch all handlers, so
3414          it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
3415          is integer_zero_node.  It would not work, however, because GCC's
3416          notion of "catch all" is stronger than our notion of "others".  Until
3417          we correctly use the cleanup interface as well, doing that would
3418          prevent the "all others" handlers from being seen, because nothing
3419          can be caught beyond a catch all from GCC's point of view.  */
3420       gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3421     }
3422
3423   start_stmt_group ();
3424   gnat_pushlevel ();
3425
3426   /* Expand a call to the begin_handler hook at the beginning of the handler,
3427      and arrange for a call to the end_handler hook to occur on every possible
3428      exit path.
3429
3430      The hooks expect a pointer to the low level occurrence. This is required
3431      for our stack management scheme because a raise inside the handler pushes
3432      a new occurrence on top of the stack, which means that this top does not
3433      necessarily match the occurrence this handler was dealing with.
3434
3435      __builtin_eh_pointer references the exception occurrence being
3436      propagated. Upon handler entry, this is the exception for which the
3437      handler is triggered. This might not be the case upon handler exit,
3438      however, as we might have a new occurrence propagated by the handler's
3439      body, and the end_handler hook called as a cleanup in this context.
3440
3441      We use a local variable to retrieve the incoming value at handler entry
3442      time, and reuse it to feed the end_handler hook's argument at exit.  */
3443
3444   gnu_current_exc_ptr
3445     = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
3446                        1, integer_zero_node);
3447   gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3448                                           ptr_type_node, gnu_current_exc_ptr,
3449                                           false, false, false, false, NULL,
3450                                           gnat_node);
3451
3452   add_stmt_with_node (build_call_1_expr (begin_handler_decl,
3453                                          gnu_incoming_exc_ptr),
3454                       gnat_node);
3455   /* ??? We don't seem to have an End_Label at hand to set the location.  */
3456   add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
3457                Empty);
3458   add_stmt_list (Statements (gnat_node));
3459   gnat_poplevel ();
3460
3461   return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
3462                  end_stmt_group ());
3463 }
3464 \f
3465 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
3466
3467 static void
3468 Compilation_Unit_to_gnu (Node_Id gnat_node)
3469 {
3470   const Node_Id gnat_unit = Unit (gnat_node);
3471   const bool body_p = (Nkind (gnat_unit) == N_Package_Body
3472                        || Nkind (gnat_unit) == N_Subprogram_Body);
3473   const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
3474   /* Make the decl for the elaboration procedure.  */
3475   tree gnu_elab_proc_decl
3476     = create_subprog_decl
3477       (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
3478        NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, gnat_unit);
3479   struct elab_info *info;
3480
3481   push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
3482   DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
3483
3484   /* Initialize the information structure for the function.  */
3485   allocate_struct_function (gnu_elab_proc_decl, false);
3486   set_cfun (NULL);
3487
3488   current_function_decl = NULL_TREE;
3489
3490   start_stmt_group ();
3491   gnat_pushlevel ();
3492
3493   current_function_decl = NULL_TREE;
3494
3495   start_stmt_group ();
3496   gnat_pushlevel ();
3497
3498   /* For a body, first process the spec if there is one.  */
3499   if (Nkind (Unit (gnat_node)) == N_Package_Body
3500       || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3501               && !Acts_As_Spec (gnat_node)))
3502     {
3503       add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
3504       finalize_from_with_types ();
3505     }
3506
3507   /* If we can inline, generate code for all the inlined subprograms.  */
3508   if (optimize)
3509     {
3510       Entity_Id gnat_entity;
3511
3512       for (gnat_entity = First_Inlined_Subprogram (gnat_node);
3513            Present (gnat_entity);
3514            gnat_entity = Next_Inlined_Subprogram (gnat_entity))
3515         {
3516           Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
3517
3518           if (Nkind (gnat_body) != N_Subprogram_Body)
3519             {
3520               /* ??? This really should always be present.  */
3521               if (No (Corresponding_Body (gnat_body)))
3522                 continue;
3523               gnat_body
3524                 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
3525             }
3526
3527           if (Present (gnat_body))
3528             {
3529               /* Define the entity first so we set DECL_EXTERNAL.  */
3530               gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
3531               add_stmt (gnat_to_gnu (gnat_body));
3532             }
3533         }
3534     }
3535
3536   if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3537     {
3538       elaborate_all_entities (gnat_node);
3539
3540       if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
3541           || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
3542           || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
3543         return;
3544     }
3545
3546   process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
3547                  true, true);
3548   add_stmt (gnat_to_gnu (Unit (gnat_node)));
3549
3550   /* Process any pragmas and actions following the unit.  */
3551   add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
3552   add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
3553   finalize_from_with_types ();
3554
3555   /* Save away what we've made so far and record this potential elaboration
3556      procedure.  */
3557   info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
3558   set_current_block_context (gnu_elab_proc_decl);
3559   gnat_poplevel ();
3560   DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
3561
3562   Sloc_to_locus
3563     (Sloc (gnat_unit),
3564      &DECL_STRUCT_FUNCTION (gnu_elab_proc_decl)->function_end_locus);
3565
3566   info->next = elab_info_list;
3567   info->elab_proc = gnu_elab_proc_decl;
3568   info->gnat_node = gnat_node;
3569   elab_info_list = info;
3570
3571   /* Generate elaboration code for this unit, if necessary, and say whether
3572      we did or not.  */
3573   pop_stack (&gnu_elab_proc_stack);
3574
3575   /* Invalidate the global renaming pointers.  This is necessary because
3576      stabilization of the renamed entities may create SAVE_EXPRs which
3577      have been tied to a specific elaboration routine just above.  */
3578   invalidate_global_renaming_pointers ();
3579 }
3580 \f
3581 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
3582    as gigi is concerned.  This is used to avoid conversions on the LHS.  */
3583
3584 static bool
3585 unchecked_conversion_nop (Node_Id gnat_node)
3586 {
3587   Entity_Id from_type, to_type;
3588
3589   /* The conversion must be on the LHS of an assignment or an actual parameter
3590      of a call.  Otherwise, even if the conversion was essentially a no-op, it
3591      could de facto ensure type consistency and this should be preserved.  */
3592