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