gcc/ada/gcc-interface/trans.c

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