gcc/ada/gcc-interface/trans.c

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