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