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