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