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-2011, 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 "ggc.h"
  33 #include "output.h"
  34 #include "libfuncs.h"   /* For set_stack_check_libfunc.  */
  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 /* Stack of exception pointer variables.  Each entry is the VAR_DECL
 157    that stores the address of the raised exception.  Nonzero means we
 158    are in an exception handler.  Not used in the zero-cost case.  */
 159 static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack;
 160
 161 /* Stack for storing the current elaboration procedure decl.  */
 162 static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack;
 163
 164 /* Stack of labels to be used as a goto target instead of a return in
 165    some functions.  See processing for N_Subprogram_Body.  */
 166 static GTY(()) VEC(tree,gc) *gnu_return_label_stack;
 167
 168 /* Stack of variable for the return value of a function with copy-in/copy-out
 169    parameters.  See processing for N_Subprogram_Body.  */
 170 static GTY(()) VEC(tree,gc) *gnu_return_var_stack;
 171
 172 /* Stack of LOOP_STMT nodes.  */
 173 static GTY(()) VEC(tree,gc) *gnu_loop_label_stack;
 174
 175 /* The stacks for N_{Push,Pop}_*_Label.  */
 176 static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack;
 177 static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack;
 178 static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack;
 179
 180 /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
 181 static enum tree_code gnu_codes[Number_Node_Kinds];
 182
 183 static void init_code_table (void);
 184 static void Compilation_Unit_to_gnu (Node_Id);
 185 static void record_code_position (Node_Id);
 186 static void insert_code_for (Node_Id);
 187 static void add_cleanup (tree, Node_Id);
 188 static void add_stmt_list (List_Id);
 189 static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id);
 190 static tree build_stmt_group (List_Id, bool);
 191 static enum gimplify_status gnat_gimplify_stmt (tree *);
 192 static void elaborate_all_entities (Node_Id);
 193 static void process_freeze_entity (Node_Id);
 194 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
 195 static tree emit_range_check (tree, Node_Id, Node_Id);
 196 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
 197 static tree emit_check (tree, tree, int, Node_Id);
 198 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
 199 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
 200 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
 201 static bool smaller_form_type_p (tree, tree);
 202 static bool addressable_p (tree, tree);
 203 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 204 static tree extract_values (tree, tree);
 205 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
 206 static tree maybe_implicit_deref (tree);
 207 static void set_expr_location_from_node (tree, Node_Id);
 208 static void set_gnu_expr_location_from_node (tree, Node_Id);
 209 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
 210 static tree build_raise_check (int, tree, enum exception_info_kind);
 211
 212 /* Hooks for debug info back-ends, only supported and used in a restricted set
 213    of configurations.  */
 214 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
 215 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
 216 \f
 217 /* This is the main program of the back-end.  It sets up all the table
 218    structures and then generates code.  */
 219
 220 void
 221 gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
 222       struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
 223       struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
 224       struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
 225       struct List_Header *list_headers_ptr, Nat number_file,
 226       struct File_Info_Type *file_info_ptr,
 227       Entity_Id standard_boolean, Entity_Id standard_integer,
 228       Entity_Id standard_character, Entity_Id standard_long_long_float,
 229       Entity_Id standard_exception_type, Int gigi_operating_mode)
 230 {
 231   Entity_Id gnat_literal;
 232   tree long_long_float_type, exception_type, t;
 233   tree int64_type = gnat_type_for_size (64, 0);
 234   struct elab_info *info;
 235   int i;
 236
 237   max_gnat_nodes = max_gnat_node;
 238
 239   Nodes_Ptr = nodes_ptr;
 240   Next_Node_Ptr = next_node_ptr;
 241   Prev_Node_Ptr = prev_node_ptr;
 242   Elists_Ptr = elists_ptr;
 243   Elmts_Ptr = elmts_ptr;
 244   Strings_Ptr = strings_ptr;
 245   String_Chars_Ptr = string_chars_ptr;
 246   List_Headers_Ptr = list_headers_ptr;
 247
 248   type_annotate_only = (gigi_operating_mode == 1);
 249
 250   gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
 251
 252   /* Declare the name of the compilation unit as the first global
 253      name in order to make the middle-end fully deterministic.  */
 254   t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
 255   first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
 256
 257   for (i = 0; i < number_file; i++)
 258     {
 259       /* Use the identifier table to make a permanent copy of the filename as
 260          the name table gets reallocated after Gigi returns but before all the
 261          debugging information is output.  The __gnat_to_canonical_file_spec
 262          call translates filenames from pragmas Source_Reference that contain
 263          host style syntax not understood by gdb.  */
 264       const char *filename
 265         = IDENTIFIER_POINTER
 266            (get_identifier
 267             (__gnat_to_canonical_file_spec
 268              (Get_Name_String (file_info_ptr[i].File_Name))));
 269
 270       /* We rely on the order isomorphism between files and line maps.  */
 271       gcc_assert ((int) line_table->used == i);
 272
 273       /* We create the line map for a source file at once, with a fixed number
 274          of columns chosen to avoid jumping over the next power of 2.  */
 275       linemap_add (line_table, LC_ENTER, 0, filename, 1);
 276       linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
 277       linemap_position_for_column (line_table, 252 - 1);
 278       linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
 279     }
 280
 281   /* Initialize ourselves.  */
 282   init_code_table ();
 283   init_gnat_to_gnu ();
 284   init_dummy_type ();
 285
 286   /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
 287      errors.  */
 288   if (type_annotate_only)
 289     {
 290       TYPE_SIZE (void_type_node) = bitsize_zero_node;
 291       TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
 292     }
 293
 294   /* Enable GNAT stack checking method if needed */
 295   if (!Stack_Check_Probes_On_Target)
 296     set_stack_check_libfunc ("_gnat_stack_check");
 297
 298   /* Retrieve alignment settings.  */
 299   double_float_alignment = get_target_double_float_alignment ();
 300   double_scalar_alignment = get_target_double_scalar_alignment ();
 301
 302   /* Record the builtin types.  Define `integer' and `character' first so that
 303      dbx will output them first.  */
 304   record_builtin_type ("integer", integer_type_node);
 305   record_builtin_type ("character", unsigned_char_type_node);
 306   record_builtin_type ("boolean", boolean_type_node);
 307   record_builtin_type ("void", void_type_node);
 308
 309   /* Save the type we made for integer as the type for Standard.Integer.  */
 310   save_gnu_tree (Base_Type (standard_integer),
 311                  TYPE_NAME (integer_type_node),
 312                  false);
 313
 314   /* Likewise for character as the type for Standard.Character.  */
 315   save_gnu_tree (Base_Type (standard_character),
 316                  TYPE_NAME (unsigned_char_type_node),
 317                  false);
 318
 319   /* Likewise for boolean as the type for Standard.Boolean.  */
 320   save_gnu_tree (Base_Type (standard_boolean),
 321                  TYPE_NAME (boolean_type_node),
 322                  false);
 323   gnat_literal = First_Literal (Base_Type (standard_boolean));
 324   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 325   gcc_assert (t == boolean_false_node);
 326   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 327                        boolean_type_node, t, true, false, false, false,
 328                        NULL, gnat_literal);
 329   DECL_IGNORED_P (t) = 1;
 330   save_gnu_tree (gnat_literal, t, false);
 331   gnat_literal = Next_Literal (gnat_literal);
 332   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 333   gcc_assert (t == boolean_true_node);
 334   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 335                        boolean_type_node, t, true, false, false, false,
 336                        NULL, gnat_literal);
 337   DECL_IGNORED_P (t) = 1;
 338   save_gnu_tree (gnat_literal, t, false);
 339
 340   void_ftype = build_function_type (void_type_node, NULL_TREE);
 341   ptr_void_ftype = build_pointer_type (void_ftype);
 342
 343   /* Now declare run-time functions.  */
 344   t = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
 345
 346   /* malloc is a function declaration tree for a function to allocate
 347      memory.  */
 348   malloc_decl
 349     = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
 350                            build_function_type (ptr_void_type_node,
 351                                                 tree_cons (NULL_TREE,
 352                                                            sizetype, t)),
 353                            NULL_TREE, false, true, true, NULL, Empty);
 354   DECL_IS_MALLOC (malloc_decl) = 1;
 355
 356   /* malloc32 is a function declaration tree for a function to allocate
 357      32-bit memory on a 64-bit system.  Needed only on 64-bit VMS.  */
 358   malloc32_decl
 359     = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
 360                            build_function_type (ptr_void_type_node,
 361                                                 tree_cons (NULL_TREE,
 362                                                            sizetype, t)),
 363                            NULL_TREE, false, true, true, NULL, Empty);
 364   DECL_IS_MALLOC (malloc32_decl) = 1;
 365
 366   /* free is a function declaration tree for a function to free memory.  */
 367   free_decl
 368     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
 369                            build_function_type (void_type_node,
 370                                                 tree_cons (NULL_TREE,
 371                                                            ptr_void_type_node,
 372                                                            t)),
 373                            NULL_TREE, false, true, true, NULL, Empty);
 374
 375   /* This is used for 64-bit multiplication with overflow checking.  */
 376   mulv64_decl
 377     = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
 378                            build_function_type_list (int64_type, int64_type,
 379                                                      int64_type, NULL_TREE),
 380                            NULL_TREE, false, true, true, NULL, Empty);
 381
 382   /* Name of the _Parent field in tagged record types.  */
 383   parent_name_id = get_identifier (Get_Name_String (Name_uParent));
 384
 385   /* Name of the Exception_Data type defined in System.Standard_Library.  */
 386   exception_data_name_id
 387     = get_identifier ("system__standard_library__exception_data");
 388
 389   /* Make the types and functions used for exception processing.  */
 390   jmpbuf_type
 391     = build_array_type (gnat_type_for_mode (Pmode, 0),
 392                         build_index_type (size_int (5)));
 393   record_builtin_type ("JMPBUF_T", jmpbuf_type);
 394   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
 395
 396   /* Functions to get and set the jumpbuf pointer for the current thread.  */
 397   get_jmpbuf_decl
 398     = create_subprog_decl
 399     (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
 400      NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
 401      NULL_TREE, false, true, true, NULL, Empty);
 402   DECL_IGNORED_P (get_jmpbuf_decl) = 1;
 403
 404   set_jmpbuf_decl
 405     = create_subprog_decl
 406     (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
 407      NULL_TREE,
 408      build_function_type (void_type_node,
 409                           tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
 410      NULL_TREE, false, true, true, NULL, Empty);
 411   DECL_IGNORED_P (set_jmpbuf_decl) = 1;
 412
 413   /* setjmp returns an integer and has one operand, which is a pointer to
 414      a jmpbuf.  */
 415   setjmp_decl
 416     = create_subprog_decl
 417       (get_identifier ("__builtin_setjmp"), NULL_TREE,
 418        build_function_type (integer_type_node,
 419                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, t)),
 420        NULL_TREE, false, true, true, NULL, Empty);
 421   DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
 422   DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
 423
 424   /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
 425      address.  */
 426   update_setjmp_buf_decl
 427     = create_subprog_decl
 428       (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
 429        build_function_type (void_type_node,
 430                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, t)),
 431        NULL_TREE, false, true, true, NULL, Empty);
 432   DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
 433   DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
 434
 435   /* Hooks to call when entering/leaving an exception handler.  */
 436   begin_handler_decl
 437     = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
 438                            build_function_type (void_type_node,
 439                                                 tree_cons (NULL_TREE,
 440                                                            ptr_void_type_node,
 441                                                            t)),
 442                            NULL_TREE, false, true, true, NULL, Empty);
 443   DECL_IGNORED_P (begin_handler_decl) = 1;
 444
 445   end_handler_decl
 446     = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
 447                            build_function_type (void_type_node,
 448                                                 tree_cons (NULL_TREE,
 449                                                            ptr_void_type_node,
 450                                                            t)),
 451                            NULL_TREE, false, true, true, NULL, Empty);
 452   DECL_IGNORED_P (end_handler_decl) = 1;
 453
 454   /* If in no exception handlers mode, all raise statements are redirected to
 455      __gnat_last_chance_handler.  No need to redefine raise_nodefer_decl since
 456      this procedure will never be called in this mode.  */
 457   if (No_Exception_Handlers_Set ())
 458     {
 459       tree decl
 460         = create_subprog_decl
 461           (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
 462            build_function_type (void_type_node,
 463                                 tree_cons (NULL_TREE,
 464                                            build_pointer_type
 465                                            (unsigned_char_type_node),
 466                                            tree_cons (NULL_TREE,
 467                                                       integer_type_node,
 468                                                       t))),
 469            NULL_TREE, false, true, true, NULL, Empty);
 470       TREE_THIS_VOLATILE (decl) = 1;
 471       TREE_SIDE_EFFECTS (decl) = 1;
 472       TREE_TYPE (decl)
 473         = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
 474       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 475         gnat_raise_decls[i] = decl;
 476     }
 477   else
 478     {
 479       /* Otherwise, make one decl for each exception reason.  */
 480       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 481         gnat_raise_decls[i] = build_raise_check (i, t, exception_simple);
 482       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
 483         gnat_raise_decls_ext[i]
 484           = build_raise_check (i, t,
 485                                i == CE_Index_Check_Failed
 486                                || i == CE_Range_Check_Failed
 487                                || i == CE_Invalid_Data
 488                                ? exception_range : exception_column);
 489     }
 490
 491   /* Set the types that GCC and Gigi use from the front end.  */
 492   exception_type
 493     = gnat_to_gnu_entity (Base_Type (standard_exception_type),  NULL_TREE, 0);
 494   except_type_node = TREE_TYPE (exception_type);
 495
 496   /* Make other functions used for exception processing.  */
 497   get_excptr_decl
 498     = create_subprog_decl
 499     (get_identifier ("system__soft_links__get_gnat_exception"),
 500      NULL_TREE,
 501      build_function_type (build_pointer_type (except_type_node), NULL_TREE),
 502      NULL_TREE, false, true, true, NULL, Empty);
 503
 504   raise_nodefer_decl
 505     = create_subprog_decl
 506       (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
 507        build_function_type (void_type_node,
 508                             tree_cons (NULL_TREE,
 509                                        build_pointer_type (except_type_node),
 510                                        t)),
 511        NULL_TREE, false, true, true, NULL, Empty);
 512
 513   /* Indicate that these never return.  */
 514   TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
 515   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
 516   TREE_TYPE (raise_nodefer_decl)
 517     = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
 518                             TYPE_QUAL_VOLATILE);
 519
 520   /* Build the special descriptor type and its null node if needed.  */
 521   if (TARGET_VTABLE_USES_DESCRIPTORS)
 522     {
 523       tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
 524       tree field_list = NULL_TREE;
 525       int j;
 526       VEC(constructor_elt,gc) *null_vec = NULL;
 527       constructor_elt *elt;
 528
 529       fdesc_type_node = make_node (RECORD_TYPE);
 530       VEC_safe_grow (constructor_elt, gc, null_vec,
 531                      TARGET_VTABLE_USES_DESCRIPTORS);
 532       elt = (VEC_address (constructor_elt,null_vec)
 533              + TARGET_VTABLE_USES_DESCRIPTORS - 1);
 534
 535       for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
 536         {
 537           tree field
 538             = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
 539                                  NULL_TREE, NULL_TREE, 0, 1);
 540           TREE_CHAIN (field) = field_list;
 541           field_list = field;
 542           elt->index = field;
 543           elt->value = null_node;
 544           elt--;
 545         }
 546
 547       finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
 548       record_builtin_type ("descriptor", fdesc_type_node);
 549       null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
 550     }
 551
 552   long_long_float_type
 553     = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
 554
 555   if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
 556     {
 557       /* In this case, the builtin floating point types are VAX float,
 558          so make up a type for use.  */
 559       longest_float_type_node = make_node (REAL_TYPE);
 560       TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
 561       layout_type (longest_float_type_node);
 562       record_builtin_type ("longest float type", longest_float_type_node);
 563     }
 564   else
 565     longest_float_type_node = TREE_TYPE (long_long_float_type);
 566
 567   /* Dummy objects to materialize "others" and "all others" in the exception
 568      tables.  These are exported by a-exexpr.adb, so see this unit for the
 569      types to use.  */
 570   others_decl
 571     = create_var_decl (get_identifier ("OTHERS"),
 572                        get_identifier ("__gnat_others_value"),
 573                        integer_type_node, NULL_TREE, true, false, true, false,
 574                        NULL, Empty);
 575
 576   all_others_decl
 577     = create_var_decl (get_identifier ("ALL_OTHERS"),
 578                        get_identifier ("__gnat_all_others_value"),
 579                        integer_type_node, NULL_TREE, true, false, true, false,
 580                        NULL, Empty);
 581
 582   main_identifier_node = get_identifier ("main");
 583
 584   /* Install the builtins we might need, either internally or as
 585      user available facilities for Intrinsic imports.  */
 586   gnat_install_builtins ();
 587
 588   VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE);
 589   VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE);
 590   VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE);
 591   VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE);
 592
 593   /* Process any Pragma Ident for the main unit.  */
 594 #ifdef ASM_OUTPUT_IDENT
 595   if (Present (Ident_String (Main_Unit)))
 596     ASM_OUTPUT_IDENT
 597       (asm_out_file,
 598        TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
 599 #endif
 600
 601   /* If we are using the GCC exception mechanism, let GCC know.  */
 602   if (Exception_Mechanism == Back_End_Exceptions)
 603     gnat_init_gcc_eh ();
 604
 605   /* Now translate the compilation unit proper.  */
 606   Compilation_Unit_to_gnu (gnat_root);
 607
 608   /* Finally see if we have any elaboration procedures to deal with.  */
 609   for (info = elab_info_list; info; info = info->next)
 610     {
 611       tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
 612
 613       /* We should have a BIND_EXPR but it may not have any statements in it.
 614          If it doesn't have any, we have nothing to do except for setting the
 615          flag on the GNAT node.  Otherwise, process the function as others.  */
 616       gnu_stmts = gnu_body;
 617       if (TREE_CODE (gnu_stmts) == BIND_EXPR)
 618         gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
 619       if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
 620         Set_Has_No_Elaboration_Code (info->gnat_node, 1);
 621       else
 622         {
 623           begin_subprog_body (info->elab_proc);
 624           end_subprog_body (gnu_body);
 625         }
 626     }
 627
 628   /* We cannot track the location of errors past this point.  */
 629   error_gnat_node = Empty;
 630 }
 631 \f
 632 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
 633    CHECK (if EXTENDED is false), or __gnat_rcheck_xx_ext (if EXTENDED is
 634    true).  */
 635
 636 static tree
 637 build_raise_check (int check, tree void_tree, enum exception_info_kind kind)
 638 {
 639   char name[21];
 640   tree result;
 641
 642   if (kind != exception_simple)
 643     {
 644       sprintf (name, "__gnat_rcheck_%.2d_ext", check);
 645       result
 646         = create_subprog_decl
 647           (get_identifier (name), NULL_TREE,
 648            build_function_type
 649            (void_type_node,
 650             tree_cons
 651             (NULL_TREE, build_pointer_type (unsigned_char_type_node),
 652              tree_cons (NULL_TREE, integer_type_node,
 653                         tree_cons (NULL_TREE, integer_type_node,
 654                                    kind == exception_column
 655                                    ? void_tree
 656                                    : tree_cons (NULL_TREE, integer_type_node,
 657                                                 tree_cons (NULL_TREE,
 658                                                            integer_type_node,
 659                                                            void_tree)))))),
 660            NULL_TREE, false, true, true, NULL, Empty);
 661     }
 662   else
 663     {
 664       sprintf (name, "__gnat_rcheck_%.2d", check);
 665       result
 666         = create_subprog_decl
 667           (get_identifier (name), NULL_TREE,
 668            build_function_type
 669            (void_type_node,
 670             tree_cons
 671             (NULL_TREE, build_pointer_type (unsigned_char_type_node),
 672              tree_cons (NULL_TREE, integer_type_node, void_tree))),
 673            NULL_TREE, false, true, true, NULL, Empty);
 674     }
 675
 676   TREE_THIS_VOLATILE (result) = 1;
 677   TREE_SIDE_EFFECTS (result) = 1;
 678   TREE_TYPE (result)
 679     = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE);
 680
 681   return result;
 682 }
 683 \f
 684 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
 685    an N_Attribute_Reference.  */
 686
 687 static int
 688 lvalue_required_for_attribute_p (Node_Id gnat_node)
 689 {
 690   switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
 691     {
 692     case Attr_Pos:
 693     case Attr_Val:
 694     case Attr_Pred:
 695     case Attr_Succ:
 696     case Attr_First:
 697     case Attr_Last:
 698     case Attr_Range_Length:
 699     case Attr_Length:
 700     case Attr_Object_Size:
 701     case Attr_Value_Size:
 702     case Attr_Component_Size:
 703     case Attr_Max_Size_In_Storage_Elements:
 704     case Attr_Min:
 705     case Attr_Max:
 706     case Attr_Null_Parameter:
 707     case Attr_Passed_By_Reference:
 708     case Attr_Mechanism_Code:
 709       return 0;
 710
 711     case Attr_Address:
 712     case Attr_Access:
 713     case Attr_Unchecked_Access:
 714     case Attr_Unrestricted_Access:
 715     case Attr_Code_Address:
 716     case Attr_Pool_Address:
 717     case Attr_Size:
 718     case Attr_Alignment:
 719     case Attr_Bit_Position:
 720     case Attr_Position:
 721     case Attr_First_Bit:
 722     case Attr_Last_Bit:
 723     case Attr_Bit:
 724     default:
 725       return 1;
 726     }
 727 }
 728
 729 /* Return a positive value if an lvalue is required for GNAT_NODE.  GNU_TYPE
 730    is the type that will be used for GNAT_NODE in the translated GNU tree.
 731    CONSTANT indicates whether the underlying object represented by GNAT_NODE
 732    is constant in the Ada sense.  If it is, ADDRESS_OF_CONSTANT indicates
 733    whether its value is the address of a constant and ALIASED whether it is
 734    aliased.  If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
 735
 736    The function climbs up the GNAT tree starting from the node and returns 1
 737    upon encountering a node that effectively requires an lvalue downstream.
 738    It returns int instead of bool to facilitate usage in non-purely binary
 739    logic contexts.  */
 740
 741 static int
 742 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
 743                    bool address_of_constant, bool aliased)
 744 {
 745   Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
 746
 747   switch (Nkind (gnat_parent))
 748     {
 749     case N_Reference:
 750       return 1;
 751
 752     case N_Attribute_Reference:
 753       return lvalue_required_for_attribute_p (gnat_parent);
 754
 755     case N_Parameter_Association:
 756     case N_Function_Call:
 757     case N_Procedure_Call_Statement:
 758       /* If the parameter is by reference, an lvalue is required.  */
 759       return (!constant
 760               || must_pass_by_ref (gnu_type)
 761               || default_pass_by_ref (gnu_type));
 762
 763     case N_Indexed_Component:
 764       /* Only the array expression can require an lvalue.  */
 765       if (Prefix (gnat_parent) != gnat_node)
 766         return 0;
 767
 768       /* ??? Consider that referencing an indexed component with a
 769          non-constant index forces the whole aggregate to memory.
 770          Note that N_Integer_Literal is conservative, any static
 771          expression in the RM sense could probably be accepted.  */
 772       for (gnat_temp = First (Expressions (gnat_parent));
 773            Present (gnat_temp);
 774            gnat_temp = Next (gnat_temp))
 775         if (Nkind (gnat_temp) != N_Integer_Literal)
 776           return 1;
 777
 778       /* ... fall through ... */
 779
 780     case N_Slice:
 781       /* Only the array expression can require an lvalue.  */
 782       if (Prefix (gnat_parent) != gnat_node)
 783         return 0;
 784
 785       aliased |= Has_Aliased_Components (Etype (gnat_node));
 786       return lvalue_required_p (gnat_parent, gnu_type, constant,
 787                                 address_of_constant, aliased);
 788
 789     case N_Selected_Component:
 790       aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
 791       return lvalue_required_p (gnat_parent, gnu_type, constant,
 792                                 address_of_constant, aliased);
 793
 794     case N_Object_Renaming_Declaration:
 795       /* We need to make a real renaming only if the constant object is
 796          aliased or if we may use a renaming pointer; otherwise we can
 797          optimize and return the rvalue.  We make an exception if the object
 798          is an identifier since in this case the rvalue can be propagated
 799          attached to the CONST_DECL.  */
 800       return (!constant
 801               || aliased
 802               /* This should match the constant case of the renaming code.  */
 803               || Is_Composite_Type
 804                  (Underlying_Type (Etype (Name (gnat_parent))))
 805               || Nkind (Name (gnat_parent)) == N_Identifier);
 806
 807     case N_Object_Declaration:
 808       /* We cannot use a constructor if this is an atomic object because
 809          the actual assignment might end up being done component-wise.  */
 810       return (!constant
 811               ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 812                  && Is_Atomic (Defining_Entity (gnat_parent)))
 813               /* We don't use a constructor if this is a class-wide object
 814                  because the effective type of the object is the equivalent
 815                  type of the class-wide subtype and it smashes most of the
 816                  data into an array of bytes to which we cannot convert.  */
 817               || Ekind ((Etype (Defining_Entity (gnat_parent))))
 818                  == E_Class_Wide_Subtype);
 819
 820     case N_Assignment_Statement:
 821       /* We cannot use a constructor if the LHS is an atomic object because
 822          the actual assignment might end up being done component-wise.  */
 823       return (!constant
 824               || Name (gnat_parent) == gnat_node
 825               || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 826                   && Is_Atomic (Entity (Name (gnat_parent)))));
 827
 828     case N_Unchecked_Type_Conversion:
 829         if (!constant)
 830           return 1;
 831
 832       /* ... fall through ... */
 833
 834     case N_Type_Conversion:
 835     case N_Qualified_Expression:
 836       /* We must look through all conversions because we may need to bypass
 837          an intermediate conversion that is meant to be purely formal.  */
 838      return lvalue_required_p (gnat_parent,
 839                                get_unpadded_type (Etype (gnat_parent)),
 840                                constant, address_of_constant, aliased);
 841
 842     case N_Allocator:
 843       /* We should only reach here through the N_Qualified_Expression case.
 844          Force an lvalue for composite types since a block-copy to the newly
 845          allocated area of memory is made.  */
 846       return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
 847
 848    case N_Explicit_Dereference:
 849       /* We look through dereferences for address of constant because we need
 850          to handle the special cases listed above.  */
 851       if (constant && address_of_constant)
 852         return lvalue_required_p (gnat_parent,
 853                                   get_unpadded_type (Etype (gnat_parent)),
 854                                   true, false, true);
 855
 856       /* ... fall through ... */
 857
 858     default:
 859       return 0;
 860     }
 861
 862   gcc_unreachable ();
 863 }
 864
 865 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
 866    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer
 867    to where we should place the result type.  */
 868
 869 static tree
 870 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 871 {
 872   Node_Id gnat_temp, gnat_temp_type;
 873   tree gnu_result, gnu_result_type;
 874
 875   /* Whether we should require an lvalue for GNAT_NODE.  Needed in
 876      specific circumstances only, so evaluated lazily.  < 0 means
 877      unknown, > 0 means known true, 0 means known false.  */
 878   int require_lvalue = -1;
 879
 880   /* If GNAT_NODE is a constant, whether we should use the initialization
 881      value instead of the constant entity, typically for scalars with an
 882      address clause when the parent doesn't require an lvalue.  */
 883   bool use_constant_initializer = false;
 884
 885   /* If the Etype of this node does not equal the Etype of the Entity,
 886      something is wrong with the entity map, probably in generic
 887      instantiation. However, this does not apply to types. Since we sometime
 888      have strange Ekind's, just do this test for objects. Also, if the Etype of
 889      the Entity is private, the Etype of the N_Identifier is allowed to be the
 890      full type and also we consider a packed array type to be the same as the
 891      original type. Similarly, a class-wide type is equivalent to a subtype of
 892      itself. Finally, if the types are Itypes, one may be a copy of the other,
 893      which is also legal.  */
 894   gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
 895                ? gnat_node : Entity (gnat_node));
 896   gnat_temp_type = Etype (gnat_temp);
 897
 898   gcc_assert (Etype (gnat_node) == gnat_temp_type
 899               || (Is_Packed (gnat_temp_type)
 900                   && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
 901               || (Is_Class_Wide_Type (Etype (gnat_node)))
 902               || (IN (Ekind (gnat_temp_type), Private_Kind)
 903                   && Present (Full_View (gnat_temp_type))
 904                   && ((Etype (gnat_node) == Full_View (gnat_temp_type))
 905                       || (Is_Packed (Full_View (gnat_temp_type))
 906                           && (Etype (gnat_node)
 907                               == Packed_Array_Type (Full_View
 908                                                     (gnat_temp_type))))))
 909               || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
 910               || !(Ekind (gnat_temp) == E_Variable
 911                    || Ekind (gnat_temp) == E_Component
 912                    || Ekind (gnat_temp) == E_Constant
 913                    || Ekind (gnat_temp) == E_Loop_Parameter
 914                    || IN (Ekind (gnat_temp), Formal_Kind)));
 915
 916   /* If this is a reference to a deferred constant whose partial view is an
 917      unconstrained private type, the proper type is on the full view of the
 918      constant, not on the full view of the type, which may be unconstrained.
 919
 920      This may be a reference to a type, for example in the prefix of the
 921      attribute Position, generated for dispatching code (see Make_DT in
 922      exp_disp,adb). In that case we need the type itself, not is parent,
 923      in particular if it is a derived type  */
 924   if (Is_Private_Type (gnat_temp_type)
 925       && Has_Unknown_Discriminants (gnat_temp_type)
 926       && Ekind (gnat_temp) == E_Constant
 927       && Present (Full_View (gnat_temp)))
 928     {
 929       gnat_temp = Full_View (gnat_temp);
 930       gnat_temp_type = Etype (gnat_temp);
 931     }
 932   else
 933     {
 934       /* We want to use the Actual_Subtype if it has already been elaborated,
 935          otherwise the Etype.  Avoid using Actual_Subtype for packed arrays to
 936          simplify things.  */
 937       if ((Ekind (gnat_temp) == E_Constant
 938            || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
 939           && !(Is_Array_Type (Etype (gnat_temp))
 940                && Present (Packed_Array_Type (Etype (gnat_temp))))
 941           && Present (Actual_Subtype (gnat_temp))
 942           && present_gnu_tree (Actual_Subtype (gnat_temp)))
 943         gnat_temp_type = Actual_Subtype (gnat_temp);
 944       else
 945         gnat_temp_type = Etype (gnat_node);
 946     }
 947
 948   /* Expand the type of this identifier first, in case it is an enumeral
 949      literal, which only get made when the type is expanded.  There is no
 950      order-of-elaboration issue here.  */
 951   gnu_result_type = get_unpadded_type (gnat_temp_type);
 952
 953   /* If this is a non-imported scalar constant with an address clause,
 954      retrieve the value instead of a pointer to be dereferenced unless
 955      an lvalue is required.  This is generally more efficient and actually
 956      required if this is a static expression because it might be used
 957      in a context where a dereference is inappropriate, such as a case
 958      statement alternative or a record discriminant.  There is no possible
 959      volatile-ness short-circuit here since Volatile constants must be
 960      imported per C.6.  */
 961   if (Ekind (gnat_temp) == E_Constant
 962       && Is_Scalar_Type (gnat_temp_type)
 963       && !Is_Imported (gnat_temp)
 964       && Present (Address_Clause (gnat_temp)))
 965     {
 966       require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
 967                                           false, Is_Aliased (gnat_temp));
 968       use_constant_initializer = !require_lvalue;
 969     }
 970
 971   if (use_constant_initializer)
 972     {
 973       /* If this is a deferred constant, the initializer is attached to
 974          the full view.  */
 975       if (Present (Full_View (gnat_temp)))
 976         gnat_temp = Full_View (gnat_temp);
 977
 978       gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
 979     }
 980   else
 981     gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
 982
 983   /* Some objects (such as parameters passed by reference, globals of
 984      variable size, and renamed objects) actually represent the address
 985      of the object.  In that case, we must do the dereference.  Likewise,
 986      deal with parameters to foreign convention subprograms.  */
 987   if (DECL_P (gnu_result)
 988       && (DECL_BY_REF_P (gnu_result)
 989           || (TREE_CODE (gnu_result) == PARM_DECL
 990               && DECL_BY_COMPONENT_PTR_P (gnu_result))))
 991     {
 992       const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
 993       tree renamed_obj;
 994
 995       if (TREE_CODE (gnu_result) == PARM_DECL
 996           && DECL_BY_DOUBLE_REF_P (gnu_result))
 997         {
 998           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
 999           if (TREE_CODE (gnu_result) == INDIRECT_REF)
1000             TREE_THIS_NOTRAP (gnu_result) = 1;
1001         }
1002
1003       if (TREE_CODE (gnu_result) == PARM_DECL
1004           && DECL_BY_COMPONENT_PTR_P (gnu_result))
1005         {
1006           gnu_result
1007             = build_unary_op (INDIRECT_REF, NULL_TREE,
1008                               convert (build_pointer_type (gnu_result_type),
1009                                        gnu_result));
1010           if (TREE_CODE (gnu_result) == INDIRECT_REF)
1011             TREE_THIS_NOTRAP (gnu_result) = 1;
1012         }
1013
1014       /* If it's a renaming pointer and we are at the right binding level,
1015          we can reference the renamed object directly, since the renamed
1016          expression has been protected against multiple evaluations.  */
1017       else if (TREE_CODE (gnu_result) == VAR_DECL
1018                && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result))
1019                && (!DECL_RENAMING_GLOBAL_P (gnu_result)
1020                    || global_bindings_p ()))
1021         gnu_result = renamed_obj;
1022
1023       /* Return the underlying CST for a CONST_DECL like a few lines below,
1024          after dereferencing in this case.  */
1025       else if (TREE_CODE (gnu_result) == CONST_DECL)
1026         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
1027                                      DECL_INITIAL (gnu_result));
1028
1029       else
1030         {
1031           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1032           if (TREE_CODE (gnu_result) == INDIRECT_REF)
1033             TREE_THIS_NOTRAP (gnu_result) = 1;
1034         }
1035
1036       if (read_only)
1037         TREE_READONLY (gnu_result) = 1;
1038     }
1039
1040   /* The GNAT tree has the type of a function as the type of its result.  Also
1041      use the type of the result if the Etype is a subtype which is nominally
1042      unconstrained.  But remove any padding from the resulting type.  */
1043   if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1044       || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
1045     {
1046       gnu_result_type = TREE_TYPE (gnu_result);
1047       if (TYPE_IS_PADDING_P (gnu_result_type))
1048         gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1049     }
1050
1051   /* If we have a constant declaration and its initializer, try to return the
1052      latter to avoid the need to call fold in lots of places and the need for
1053      elaboration code if this identifier is used as an initializer itself.  */
1054   if (TREE_CONSTANT (gnu_result)
1055       && DECL_P (gnu_result)
1056       && DECL_INITIAL (gnu_result))
1057     {
1058       bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1059                             && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1060       bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1061                                   && DECL_CONST_ADDRESS_P (gnu_result));
1062
1063       /* If there is a (corresponding) variable or this is the address of a
1064          constant, we only want to return the initializer if an lvalue isn't
1065          required.  Evaluate this now if we have not already done so.  */
1066       if ((!constant_only || address_of_constant) && require_lvalue < 0)
1067         require_lvalue
1068           = lvalue_required_p (gnat_node, gnu_result_type, true,
1069                                address_of_constant, Is_Aliased (gnat_temp));
1070
1071       /* ??? We need to unshare the initializer if the object is external
1072          as such objects are not marked for unsharing if we are not at the
1073          global level.  This should be fixed in add_decl_expr.  */
1074       if ((constant_only && !address_of_constant) || !require_lvalue)
1075         gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
1076     }
1077
1078   *gnu_result_type_p = gnu_result_type;
1079
1080   return gnu_result;
1081 }
1082 \f
1083 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
1084    any statements we generate.  */
1085
1086 static tree
1087 Pragma_to_gnu (Node_Id gnat_node)
1088 {
1089   Node_Id gnat_temp;
1090   tree gnu_result = alloc_stmt_list ();
1091
1092   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1093      annotating types.  */
1094   if (type_annotate_only
1095       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1096     return gnu_result;
1097
1098   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1099     {
1100     case Pragma_Inspection_Point:
1101       /* Do nothing at top level: all such variables are already viewable.  */
1102       if (global_bindings_p ())
1103         break;
1104
1105       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1106            Present (gnat_temp);
1107            gnat_temp = Next (gnat_temp))
1108         {
1109           Node_Id gnat_expr = Expression (gnat_temp);
1110           tree gnu_expr = gnat_to_gnu (gnat_expr);
1111           int use_address;
1112           enum machine_mode mode;
1113           tree asm_constraint = NULL_TREE;
1114 #ifdef ASM_COMMENT_START
1115           char *comment;
1116 #endif
1117
1118           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1119             gnu_expr = TREE_OPERAND (gnu_expr, 0);
1120
1121           /* Use the value only if it fits into a normal register,
1122              otherwise use the address.  */
1123           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1124           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1125                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1126                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1127
1128           if (use_address)
1129             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1130
1131 #ifdef ASM_COMMENT_START
1132           comment = concat (ASM_COMMENT_START,
1133                             " inspection point: ",
1134                             Get_Name_String (Chars (gnat_expr)),
1135                             use_address ? " address" : "",
1136                             " is in %0",
1137                             NULL);
1138           asm_constraint = build_string (strlen (comment), comment);
1139           free (comment);
1140 #endif
1141           gnu_expr = build5 (ASM_EXPR, void_type_node,
1142                              asm_constraint,
1143                              NULL_TREE,
1144                              tree_cons
1145                              (build_tree_list (NULL_TREE,
1146                                                build_string (1, "g")),
1147                               gnu_expr, NULL_TREE),
1148                              NULL_TREE, NULL_TREE);
1149           ASM_VOLATILE_P (gnu_expr) = 1;
1150           set_expr_location_from_node (gnu_expr, gnat_node);
1151           append_to_statement_list (gnu_expr, &gnu_result);
1152         }
1153       break;
1154
1155     case Pragma_Optimize:
1156       switch (Chars (Expression
1157                      (First (Pragma_Argument_Associations (gnat_node)))))
1158         {
1159         case Name_Time:  case Name_Space:
1160           if (!optimize)
1161             post_error ("insufficient -O value?", gnat_node);
1162           break;
1163
1164         case Name_Off:
1165           if (optimize)
1166             post_error ("must specify -O0?", gnat_node);
1167           break;
1168
1169         default:
1170           gcc_unreachable ();
1171         }
1172       break;
1173
1174     case Pragma_Reviewable:
1175       if (write_symbols == NO_DEBUG)
1176         post_error ("must specify -g?", gnat_node);
1177       break;
1178     }
1179
1180   return gnu_result;
1181 }
1182 \f
1183 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1184    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
1185    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
1186
1187 static tree
1188 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1189 {
1190   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1191   tree gnu_type = TREE_TYPE (gnu_prefix);
1192   tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1193   bool prefix_unused = false;
1194
1195   /* If the input is a NULL_EXPR, make a new one.  */
1196   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1197     {
1198       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1199       *gnu_result_type_p = gnu_result_type;
1200       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1201     }
1202
1203   switch (attribute)
1204     {
1205     case Attr_Pos:
1206     case Attr_Val:
1207       /* These are just conversions since representation clauses for
1208          enumeration types are handled in the front-end.  */
1209       {
1210         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1211         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1212         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1213         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1214                                          checkp, checkp, true, gnat_node);
1215       }
1216       break;
1217
1218     case Attr_Pred:
1219     case Attr_Succ:
1220       /* These just add or subtract the constant 1 since representation
1221          clauses for enumeration types are handled in the front-end.  */
1222       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1223       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1224
1225       if (Do_Range_Check (First (Expressions (gnat_node))))
1226         {
1227           gnu_expr = gnat_protect_expr (gnu_expr);
1228           gnu_expr
1229             = emit_check
1230               (build_binary_op (EQ_EXPR, boolean_type_node,
1231                                 gnu_expr,
1232                                 attribute == Attr_Pred
1233                                 ? TYPE_MIN_VALUE (gnu_result_type)
1234                                 : TYPE_MAX_VALUE (gnu_result_type)),
1235                gnu_expr, CE_Range_Check_Failed, gnat_node);
1236         }
1237
1238       gnu_result
1239         = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1240                            gnu_result_type, gnu_expr,
1241                            convert (gnu_result_type, integer_one_node));
1242       break;
1243
1244     case Attr_Address:
1245     case Attr_Unrestricted_Access:
1246       /* Conversions don't change addresses but can cause us to miss the
1247          COMPONENT_REF case below, so strip them off.  */
1248       gnu_prefix = remove_conversions (gnu_prefix,
1249                                        !Must_Be_Byte_Aligned (gnat_node));
1250
1251       /* If we are taking 'Address of an unconstrained object, this is the
1252          pointer to the underlying array.  */
1253       if (attribute == Attr_Address)
1254         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1255
1256       /* If we are building a static dispatch table, we have to honor
1257          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1258          with the C++ ABI.  We do it in the non-static case as well,
1259          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
1260       else if (TARGET_VTABLE_USES_DESCRIPTORS
1261                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1262         {
1263           tree gnu_field, t;
1264           /* Descriptors can only be built here for top-level functions.  */
1265           bool build_descriptor = (global_bindings_p () != 0);
1266           int i;
1267           VEC(constructor_elt,gc) *gnu_vec = NULL;
1268           constructor_elt *elt;
1269
1270           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1271
1272           /* If we're not going to build the descriptor, we have to retrieve
1273              the one which will be built by the linker (or by the compiler
1274              later if a static chain is requested).  */
1275           if (!build_descriptor)
1276             {
1277               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1278               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1279                                          gnu_result);
1280               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1281             }
1282
1283           VEC_safe_grow (constructor_elt, gc, gnu_vec,
1284                          TARGET_VTABLE_USES_DESCRIPTORS);
1285           elt = (VEC_address (constructor_elt, gnu_vec)
1286                  + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1287           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1288                i < TARGET_VTABLE_USES_DESCRIPTORS;
1289                gnu_field = TREE_CHAIN (gnu_field), i++)
1290             {
1291               if (build_descriptor)
1292                 {
1293                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1294                               build_int_cst (NULL_TREE, i));
1295                   TREE_CONSTANT (t) = 1;
1296                 }
1297               else
1298                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1299                             gnu_field, NULL_TREE);
1300
1301               elt->index = gnu_field;
1302               elt->value = t;
1303               elt--;
1304             }
1305
1306           gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1307           break;
1308         }
1309
1310       /* ... fall through ... */
1311
1312     case Attr_Access:
1313     case Attr_Unchecked_Access:
1314     case Attr_Code_Address:
1315       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1316       gnu_result
1317         = build_unary_op (((attribute == Attr_Address
1318                             || attribute == Attr_Unrestricted_Access)
1319                            && !Must_Be_Byte_Aligned (gnat_node))
1320                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
1321                           gnu_result_type, gnu_prefix);
1322
1323       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1324          don't try to build a trampoline.  */
1325       if (attribute == Attr_Code_Address)
1326         {
1327           for (gnu_expr = gnu_result;
1328                CONVERT_EXPR_P (gnu_expr);
1329                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1330             TREE_CONSTANT (gnu_expr) = 1;
1331
1332           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1333             TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1334         }
1335
1336       /* For other address attributes applied to a nested function,
1337          find an inner ADDR_EXPR and annotate it so that we can issue
1338          a useful warning with -Wtrampolines.  */
1339       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1340         {
1341           for (gnu_expr = gnu_result;
1342                CONVERT_EXPR_P (gnu_expr);
1343                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1344             ;
1345
1346           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1347               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1348             {
1349               set_expr_location_from_node (gnu_expr, gnat_node);
1350
1351               /* Check that we're not violating the No_Implicit_Dynamic_Code
1352                  restriction.  Be conservative if we don't know anything
1353                  about the trampoline strategy for the target.  */
1354               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1355             }
1356         }
1357       break;
1358
1359     case Attr_Pool_Address:
1360       {
1361         tree gnu_obj_type;
1362         tree gnu_ptr = gnu_prefix;
1363
1364         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1365
1366         /* If this is an unconstrained array, we know the object has been
1367            allocated with the template in front of the object.  So compute
1368            the template address.  */
1369         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1370           gnu_ptr
1371             = convert (build_pointer_type
1372                        (TYPE_OBJECT_RECORD_TYPE
1373                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1374                        gnu_ptr);
1375
1376         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1377         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1378             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1379           {
1380             tree gnu_char_ptr_type
1381               = build_pointer_type (unsigned_char_type_node);
1382             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1383             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1384             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1385                                        gnu_ptr, gnu_pos);
1386           }
1387
1388         gnu_result = convert (gnu_result_type, gnu_ptr);
1389       }
1390       break;
1391
1392     case Attr_Size:
1393     case Attr_Object_Size:
1394     case Attr_Value_Size:
1395     case Attr_Max_Size_In_Storage_Elements:
1396       gnu_expr = gnu_prefix;
1397
1398       /* Remove NOPs and conversions between original and packable version
1399          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1400          to see if a COMPONENT_REF was involved.  */
1401       while (TREE_CODE (gnu_expr) == NOP_EXPR
1402              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1403                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1404                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1405                     == RECORD_TYPE
1406                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1407                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1408         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1409
1410       gnu_prefix = remove_conversions (gnu_prefix, true);
1411       prefix_unused = true;
1412       gnu_type = TREE_TYPE (gnu_prefix);
1413
1414       /* Replace an unconstrained array type with the type of the underlying
1415          array.  We can't do this with a call to maybe_unconstrained_array
1416          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1417          use the record type that will be used to allocate the object and its
1418          template.  */
1419       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1420         {
1421           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1422           if (attribute != Attr_Max_Size_In_Storage_Elements)
1423             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1424         }
1425
1426       /* If we're looking for the size of a field, return the field size.
1427          Otherwise, if the prefix is an object, or if we're looking for
1428          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1429          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1430       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1431         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1432       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1433                || attribute == Attr_Object_Size
1434                || attribute == Attr_Max_Size_In_Storage_Elements)
1435         {
1436           /* If the prefix is an object of a padded type, the GCC size isn't
1437              relevant to the programmer.  Normally what we want is the RM size,
1438              which was set from the specified size, but if it was not set, we
1439              want the size of the field.  Using the MAX of those two produces
1440              the right result in all cases.  Don't use the size of the field
1441              if it's self-referential, since that's never what's wanted.  */
1442           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1443               && TYPE_IS_PADDING_P (gnu_type)
1444               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1445             {
1446               gnu_result = rm_size (gnu_type);
1447               if (!CONTAINS_PLACEHOLDER_P
1448                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1449                 gnu_result
1450                   = size_binop (MAX_EXPR, gnu_result,
1451                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1452             }
1453           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1454             {
1455               Node_Id gnat_deref = Prefix (gnat_node);
1456               Node_Id gnat_actual_subtype
1457                 = Actual_Designated_Subtype (gnat_deref);
1458               tree gnu_ptr_type
1459                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1460
1461               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1462                   && Present (gnat_actual_subtype))
1463                 {
1464                   tree gnu_actual_obj_type
1465                     = gnat_to_gnu_type (gnat_actual_subtype);
1466                   gnu_type
1467                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1468                                                       gnu_actual_obj_type,
1469                                                       get_identifier ("SIZE"),
1470                                                       false);
1471                 }
1472
1473               gnu_result = TYPE_SIZE (gnu_type);
1474             }
1475           else
1476             gnu_result = TYPE_SIZE (gnu_type);
1477         }
1478       else
1479         gnu_result = rm_size (gnu_type);
1480
1481       /* Deal with a self-referential size by returning the maximum size for
1482          a type and by qualifying the size with the object otherwise.  */
1483       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1484         {
1485           if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1486             gnu_result = max_size (gnu_result, true);
1487           else
1488             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1489         }
1490
1491       /* If the type contains a template, subtract its size.  */
1492       if (TREE_CODE (gnu_type) == RECORD_TYPE
1493           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1494         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1495                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1496
1497       /* For 'Max_Size_In_Storage_Elements, adjust the unit.  */
1498       if (attribute == Attr_Max_Size_In_Storage_Elements)
1499         gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1500
1501       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1502       break;
1503
1504     case Attr_Alignment:
1505       {
1506         unsigned int align;
1507
1508         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1509             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1510           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1511
1512         gnu_type = TREE_TYPE (gnu_prefix);
1513         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1514         prefix_unused = true;
1515
1516         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1517           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1518         else
1519           {
1520             Node_Id gnat_prefix = Prefix (gnat_node);
1521             Entity_Id gnat_type = Etype (gnat_prefix);
1522             unsigned int double_align;
1523             bool is_capped_double, align_clause;
1524
1525             /* If the default alignment of "double" or larger scalar types is
1526                specifically capped and there is an alignment clause neither
1527                on the type nor on the prefix itself, return the cap.  */
1528             if ((double_align = double_float_alignment) > 0)
1529               is_capped_double
1530                 = is_double_float_or_array (gnat_type, &align_clause);
1531             else if ((double_align = double_scalar_alignment) > 0)
1532               is_capped_double
1533                 = is_double_scalar_or_array (gnat_type, &align_clause);
1534             else
1535               is_capped_double = align_clause = false;
1536
1537             if (is_capped_double
1538                 && Nkind (gnat_prefix) == N_Identifier
1539                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1540               align_clause = true;
1541
1542             if (is_capped_double && !align_clause)
1543               align = double_align;
1544             else
1545               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1546           }
1547
1548         gnu_result = size_int (align);
1549       }
1550       break;
1551
1552     case Attr_First:
1553     case Attr_Last:
1554     case Attr_Range_Length:
1555       prefix_unused = true;
1556
1557       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1558         {
1559           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1560
1561           if (attribute == Attr_First)
1562             gnu_result = TYPE_MIN_VALUE (gnu_type);
1563           else if (attribute == Attr_Last)
1564             gnu_result = TYPE_MAX_VALUE (gnu_type);
1565           else
1566             gnu_result
1567               = build_binary_op
1568                 (MAX_EXPR, get_base_type (gnu_result_type),
1569                  build_binary_op
1570                  (PLUS_EXPR, get_base_type (gnu_result_type),
1571                   build_binary_op (MINUS_EXPR,
1572                                    get_base_type (gnu_result_type),
1573                                    convert (gnu_result_type,
1574                                             TYPE_MAX_VALUE (gnu_type)),
1575                                    convert (gnu_result_type,
1576                                             TYPE_MIN_VALUE (gnu_type))),
1577                   convert (gnu_result_type, integer_one_node)),
1578                  convert (gnu_result_type, integer_zero_node));
1579
1580           break;
1581         }
1582
1583       /* ... fall through ... */
1584
1585     case Attr_Length:
1586       {
1587         int Dimension = (Present (Expressions (gnat_node))
1588                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1589                          : 1), i;
1590         struct parm_attr_d *pa = NULL;
1591         Entity_Id gnat_param = Empty;
1592
1593         /* Make sure any implicit dereference gets done.  */
1594         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1595         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1596         /* We treat unconstrained array In parameters specially.  */
1597         if (Nkind (Prefix (gnat_node)) == N_Identifier
1598             && !Is_Constrained (Etype (Prefix (gnat_node)))
1599             && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1600           gnat_param = Entity (Prefix (gnat_node));
1601         gnu_type = TREE_TYPE (gnu_prefix);
1602         prefix_unused = true;
1603         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1604
1605         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1606           {
1607             int ndim;
1608             tree gnu_type_temp;
1609
1610             for (ndim = 1, gnu_type_temp = gnu_type;
1611                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1612                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1613                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1614               ;
1615
1616             Dimension = ndim + 1 - Dimension;
1617           }
1618
1619         for (i = 1; i < Dimension; i++)
1620           gnu_type = TREE_TYPE (gnu_type);
1621
1622         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1623
1624         /* When not optimizing, look up the slot associated with the parameter
1625            and the dimension in the cache and create a new one on failure.  */
1626         if (!optimize && Present (gnat_param))
1627           {
1628             FOR_EACH_VEC_ELT (parm_attr, f_parm_attr_cache, i, pa)
1629               if (pa->id == gnat_param && pa->dim == Dimension)
1630                 break;
1631
1632             if (!pa)
1633               {
1634                 pa = ggc_alloc_cleared_parm_attr_d ();
1635                 pa->id = gnat_param;
1636                 pa->dim = Dimension;
1637                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1638               }
1639           }
1640
1641         /* Return the cached expression or build a new one.  */
1642         if (attribute == Attr_First)
1643           {
1644             if (pa && pa->first)
1645               {
1646                 gnu_result = pa->first;
1647                 break;
1648               }
1649
1650             gnu_result
1651               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1652           }
1653
1654         else if (attribute == Attr_Last)
1655           {
1656             if (pa && pa->last)
1657               {
1658                 gnu_result = pa->last;
1659                 break;
1660               }
1661
1662             gnu_result
1663               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1664           }
1665
1666         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1667           {
1668             if (pa && pa->length)
1669               {
1670                 gnu_result = pa->length;
1671                 break;
1672               }
1673             else
1674               {
1675                 /* We used to compute the length as max (hb - lb + 1, 0),
1676                    which could overflow for some cases of empty arrays, e.g.
1677                    when lb == index_type'first.  We now compute the length as
1678                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1679                    much rarer cases, for extremely large arrays we expect
1680                    never to encounter in practice.  In addition, the former
1681                    computation required the use of potentially constraining
1682                    signed arithmetic while the latter doesn't.  Note that
1683                    the comparison must be done in the original index type,
1684                    to avoid any overflow during the conversion.  */
1685                 tree comp_type = get_base_type (gnu_result_type);
1686                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1687                 tree lb = TYPE_MIN_VALUE (index_type);
1688                 tree hb = TYPE_MAX_VALUE (index_type);
1689                 gnu_result
1690                   = build_binary_op (PLUS_EXPR, comp_type,
1691                                      build_binary_op (MINUS_EXPR,
1692                                                       comp_type,
1693                                                       convert (comp_type, hb),
1694                                                       convert (comp_type, lb)),
1695                                      convert (comp_type, integer_one_node));
1696                 gnu_result
1697                   = build_cond_expr (comp_type,
1698                                      build_binary_op (GE_EXPR,
1699                                                       boolean_type_node,
1700                                                       hb, lb),
1701                                      gnu_result,
1702                                      convert (comp_type, integer_zero_node));
1703               }
1704           }
1705
1706         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1707            handling.  Note that these attributes could not have been used on
1708            an unconstrained array type.  */
1709         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1710
1711         /* Cache the expression we have just computed.  Since we want to do it
1712            at run time, we force the use of a SAVE_EXPR and let the gimplifier
1713            create the temporary in the outermost binding level.  We will make
1714            sure in Subprogram_Body_to_gnu that it is evaluated on all possible
1715            paths by forcing its evaluation on entry of the function.  */
1716         if (pa)
1717           {
1718             gnu_result
1719               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1720             if (attribute == Attr_First)
1721               pa->first = gnu_result;
1722             else if (attribute == Attr_Last)
1723               pa->last = gnu_result;
1724             else
1725               pa->length = gnu_result;
1726           }
1727
1728         /* Set the source location onto the predicate of the condition in the
1729            'Length case but do not do it if the expression is cached to avoid
1730            messing up the debug info.  */
1731         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1732                  && TREE_CODE (gnu_result) == COND_EXPR
1733                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1734           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1735                                        gnat_node);
1736
1737         break;
1738       }
1739
1740     case Attr_Bit_Position:
1741     case Attr_Position:
1742     case Attr_First_Bit:
1743     case Attr_Last_Bit:
1744     case Attr_Bit:
1745       {
1746         HOST_WIDE_INT bitsize;
1747         HOST_WIDE_INT bitpos;
1748         tree gnu_offset;
1749         tree gnu_field_bitpos;
1750         tree gnu_field_offset;
1751         tree gnu_inner;
1752         enum machine_mode mode;
1753         int unsignedp, volatilep;
1754
1755         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1756         gnu_prefix = remove_conversions (gnu_prefix, true);
1757         prefix_unused = true;
1758
1759         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1760            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1761         if (attribute == Attr_Bit
1762             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1763             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1764           {
1765             gnu_result = integer_zero_node;
1766             break;
1767           }
1768
1769         else
1770           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1771                       || (attribute == Attr_Bit_Position
1772                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1773
1774         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1775                              &mode, &unsignedp, &volatilep, false);
1776
1777         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1778           {
1779             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1780             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1781
1782             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1783                  TREE_CODE (gnu_inner) == COMPONENT_REF
1784                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1785                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1786               {
1787                 gnu_field_bitpos
1788                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1789                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1790                 gnu_field_offset
1791                   = size_binop (PLUS_EXPR, gnu_field_offset,
1792                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1793               }
1794           }
1795         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1796           {
1797             gnu_field_bitpos = bit_position (gnu_prefix);
1798             gnu_field_offset = byte_position (gnu_prefix);
1799           }
1800         else
1801           {
1802             gnu_field_bitpos = bitsize_zero_node;
1803             gnu_field_offset = size_zero_node;
1804           }
1805
1806         switch (attribute)
1807           {
1808           case Attr_Position:
1809             gnu_result = gnu_field_offset;
1810             break;
1811
1812           case Attr_First_Bit:
1813           case Attr_Bit:
1814             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1815             break;
1816
1817           case Attr_Last_Bit:
1818             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1819             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1820                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1821             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1822                                      bitsize_one_node);
1823             break;
1824
1825           case Attr_Bit_Position:
1826             gnu_result = gnu_field_bitpos;
1827             break;
1828                 }
1829
1830         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1831            handling.  */
1832         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1833         break;
1834       }
1835
1836     case Attr_Min:
1837     case Attr_Max:
1838       {
1839         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1840         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1841
1842         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1843         gnu_result = build_binary_op (attribute == Attr_Min
1844                                       ? MIN_EXPR : MAX_EXPR,
1845                                       gnu_result_type, gnu_lhs, gnu_rhs);
1846       }
1847       break;
1848
1849     case Attr_Passed_By_Reference:
1850       gnu_result = size_int (default_pass_by_ref (gnu_type)
1851                              || must_pass_by_ref (gnu_type));
1852       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1853       break;
1854
1855     case Attr_Component_Size:
1856       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1857           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1858         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1859
1860       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1861       gnu_type = TREE_TYPE (gnu_prefix);
1862
1863       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1864         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1865
1866       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1867              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1868         gnu_type = TREE_TYPE (gnu_type);
1869
1870       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1871
1872       /* Note this size cannot be self-referential.  */
1873       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1874       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1875       prefix_unused = true;
1876       break;
1877
1878     case Attr_Null_Parameter:
1879       /* This is just a zero cast to the pointer type for our prefix and
1880          dereferenced.  */
1881       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1882       gnu_result
1883         = build_unary_op (INDIRECT_REF, NULL_TREE,
1884                           convert (build_pointer_type (gnu_result_type),
1885                                    integer_zero_node));
1886       TREE_PRIVATE (gnu_result) = 1;
1887       break;
1888
1889     case Attr_Mechanism_Code:
1890       {
1891         int code;
1892         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1893
1894         prefix_unused = true;
1895         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1896         if (Present (Expressions (gnat_node)))
1897           {
1898             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1899
1900             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1901                  i--, gnat_obj = Next_Formal (gnat_obj))
1902               ;
1903           }
1904
1905         code = Mechanism (gnat_obj);
1906         if (code == Default)
1907           code = ((present_gnu_tree (gnat_obj)
1908                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1909                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1910                             == PARM_DECL)
1911                            && (DECL_BY_COMPONENT_PTR_P
1912                                (get_gnu_tree (gnat_obj))))))
1913                   ? By_Reference : By_Copy);
1914         gnu_result = convert (gnu_result_type, size_int (- code));
1915       }
1916       break;
1917
1918     default:
1919       /* Say we have an unimplemented attribute.  Then set the value to be
1920          returned to be a zero and hope that's something we can convert to
1921          the type of this attribute.  */
1922       post_error ("unimplemented attribute", gnat_node);
1923       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1924       gnu_result = integer_zero_node;
1925       break;
1926     }
1927
1928   /* If this is an attribute where the prefix was unused, force a use of it if
1929      it has a side-effect.  But don't do it if the prefix is just an entity
1930      name.  However, if an access check is needed, we must do it.  See second
1931      example in AARM 11.6(5.e).  */
1932   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1933       && !Is_Entity_Name (Prefix (gnat_node)))
1934     gnu_result = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix,
1935                                        gnu_result);
1936
1937   *gnu_result_type_p = gnu_result_type;
1938   return gnu_result;
1939 }
1940 \f
1941 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1942    to a GCC tree, which is returned.  */
1943
1944 static tree
1945 Case_Statement_to_gnu (Node_Id gnat_node)
1946 {
1947   tree gnu_result, gnu_expr, gnu_label;
1948   Node_Id gnat_when;
1949   bool may_fallthru = false;
1950
1951   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1952   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1953
1954   /*  The range of values in a case statement is determined by the rules in
1955       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1956       of the expression. One exception arises in the case of a simple name that
1957       is parenthesized. This still has the Etype of the name, but since it is
1958       not a name, para 7 does not apply, and we need to go to the base type.
1959       This is the only case where parenthesization affects the dynamic
1960       semantics (i.e. the range of possible values at run time that is covered
1961       by the others alternative).
1962
1963       Another exception is if the subtype of the expression is non-static.  In
1964       that case, we also have to use the base type.  */
1965   if (Paren_Count (Expression (gnat_node)) != 0
1966       || !Is_OK_Static_Subtype (Underlying_Type
1967                                 (Etype (Expression (gnat_node)))))
1968     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1969
1970   /* We build a SWITCH_EXPR that contains the code with interspersed
1971      CASE_LABEL_EXPRs for each label.  */
1972   gnu_label = create_artificial_label (input_location);
1973   start_stmt_group ();
1974
1975   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1976        Present (gnat_when);
1977        gnat_when = Next_Non_Pragma (gnat_when))
1978     {
1979       bool choices_added_p = false;
1980       Node_Id gnat_choice;
1981
1982       /* First compile all the different case choices for the current WHEN
1983          alternative.  */
1984       for (gnat_choice = First (Discrete_Choices (gnat_when));
1985            Present (gnat_choice); gnat_choice = Next (gnat_choice))
1986         {
1987           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1988
1989           switch (Nkind (gnat_choice))
1990             {
1991             case N_Range:
1992               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1993               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1994               break;
1995
1996             case N_Subtype_Indication:
1997               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1998                                                 (Constraint (gnat_choice))));
1999               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2000                                                   (Constraint (gnat_choice))));
2001               break;
2002
2003             case N_Identifier:
2004             case N_Expanded_Name:
2005               /* This represents either a subtype range or a static value of
2006                  some kind; Ekind says which.  */
2007               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2008                 {
2009                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2010
2011                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
2012                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
2013                   break;
2014                 }
2015
2016               /* ... fall through ... */
2017
2018             case N_Character_Literal:
2019             case N_Integer_Literal:
2020               gnu_low = gnat_to_gnu (gnat_choice);
2021               break;
2022
2023             case N_Others_Choice:
2024               break;
2025
2026             default:
2027               gcc_unreachable ();
2028             }
2029
2030           /* If the case value is a subtype that raises Constraint_Error at
2031              run time because of a wrong bound, then gnu_low or gnu_high is
2032              not translated into an INTEGER_CST.  In such a case, we need
2033              to ensure that the when statement is not added in the tree,
2034              otherwise it will crash the gimplifier.  */
2035           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2036               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2037             {
2038               add_stmt_with_node (build3
2039                                   (CASE_LABEL_EXPR, void_type_node,
2040                                    gnu_low, gnu_high,
2041                                    create_artificial_label (input_location)),
2042                                   gnat_choice);
2043               choices_added_p = true;
2044             }
2045         }
2046
2047       /* Push a binding level here in case variables are declared as we want
2048          them to be local to this set of statements instead of to the block
2049          containing the Case statement.  */
2050       if (choices_added_p)
2051         {
2052           tree group = build_stmt_group (Statements (gnat_when), true);
2053           bool group_may_fallthru = block_may_fallthru (group);
2054           add_stmt (group);
2055           if (group_may_fallthru)
2056             {
2057               add_stmt (build1 (GOTO_EXPR, void_type_node, gnu_label));
2058               may_fallthru = true;
2059             }
2060         }
2061     }
2062
2063   /* Now emit a definition of the label the cases branch to, if any.  */
2064   if (may_fallthru)
2065     add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2066   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2067                        end_stmt_group (), NULL_TREE);
2068
2069   return gnu_result;
2070 }
2071 \f
2072 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2073    false, or the maximum value if MAX is true, of TYPE.  */
2074
2075 static bool
2076 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2077 {
2078   tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2079
2080   if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2081     return true;
2082
2083   if (TREE_CODE (val) == NOP_EXPR)
2084     val = (max
2085            ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2086            : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2087
2088   if (TREE_CODE (val) != INTEGER_CST)
2089     return true;
2090
2091   return tree_int_cst_equal (val, min_or_max_val) == 1;
2092 }
2093
2094 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2095    If REVERSE is true, minimum value is taken as maximum value.  */
2096
2097 static inline bool
2098 can_equal_min_val_p (tree val, tree type, bool reverse)
2099 {
2100   return can_equal_min_or_max_val_p (val, type, reverse);
2101 }
2102
2103 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2104    If REVERSE is true, maximum value is taken as minimum value.  */
2105
2106 static inline bool
2107 can_equal_max_val_p (tree val, tree type, bool reverse)
2108 {
2109   return can_equal_min_or_max_val_p (val, type, !reverse);
2110 }
2111
2112 /* Return true if VAL1 can be lower than VAL2.  */
2113
2114 static bool
2115 can_be_lower_p (tree val1, tree val2)
2116 {
2117   if (TREE_CODE (val1) == NOP_EXPR)
2118     val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2119
2120   if (TREE_CODE (val1) != INTEGER_CST)
2121     return true;
2122
2123   if (TREE_CODE (val2) == NOP_EXPR)
2124     val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2125
2126   if (TREE_CODE (val2) != INTEGER_CST)
2127     return true;
2128
2129   return tree_int_cst_lt (val1, val2);
2130 }
2131
2132 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2133    to a GCC tree, which is returned.  */
2134
2135 static tree
2136 Loop_Statement_to_gnu (Node_Id gnat_node)
2137 {
2138   const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2139   tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2140                                NULL_TREE, NULL_TREE, NULL_TREE);
2141   tree gnu_loop_label = create_artificial_label (input_location);
2142   tree gnu_loop_var = NULL_TREE, gnu_cond_expr = NULL_TREE;
2143   tree gnu_result;
2144
2145   /* Set location information for statement and end label.  */
2146   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2147   Sloc_to_locus (Sloc (End_Label (gnat_node)),
2148                  &DECL_SOURCE_LOCATION (gnu_loop_label));
2149   LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2150
2151   /* Save the end label of this LOOP_STMT in a stack so that a corresponding
2152      N_Exit_Statement can find it.  */
2153   VEC_safe_push (tree, gc, gnu_loop_label_stack, gnu_loop_label);
2154
2155   /* Set the condition under which the loop must keep going.
2156      For the case "LOOP .... END LOOP;" the condition is always true.  */
2157   if (No (gnat_iter_scheme))
2158     ;
2159
2160   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2161   else if (Present (Condition (gnat_iter_scheme)))
2162     LOOP_STMT_COND (gnu_loop_stmt)
2163       = gnat_to_gnu (Condition (gnat_iter_scheme));
2164
2165   /* Otherwise we have an iteration scheme and the condition is given by the
2166      bounds of the subtype of the iteration variable.  */
2167   else
2168     {
2169       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2170       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2171       Entity_Id gnat_type = Etype (gnat_loop_var);
2172       tree gnu_type = get_unpadded_type (gnat_type);
2173       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2174       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2175       tree gnu_base_type = get_base_type (gnu_type);
2176       tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2177       tree gnu_first, gnu_last;
2178       enum tree_code update_code, test_code, shift_code;
2179       bool reverse = Reverse_Present (gnat_loop_spec), fallback = false;
2180
2181       /* We must disable modulo reduction for the iteration variable, if any,
2182          in order for the loop comparison to be effective.  */
2183       if (reverse)
2184         {
2185           gnu_first = gnu_high;
2186           gnu_last = gnu_low;
2187           update_code = MINUS_NOMOD_EXPR;
2188           test_code = GE_EXPR;
2189           shift_code = PLUS_NOMOD_EXPR;
2190         }
2191       else
2192         {
2193           gnu_first = gnu_low;
2194           gnu_last = gnu_high;
2195           update_code = PLUS_NOMOD_EXPR;
2196           test_code = LE_EXPR;
2197           shift_code = MINUS_NOMOD_EXPR;
2198         }
2199
2200       /* We use two different strategies to translate the loop, depending on
2201          whether optimization is enabled.
2202
2203          If it is, we try to generate the canonical form of loop expected by
2204          the loop optimizer, which is the do-while form:
2205
2206              ENTRY_COND
2207            loop:
2208              TOP_UPDATE
2209              BODY
2210              BOTTOM_COND
2211              GOTO loop
2212
2213          This makes it possible to bypass loop header copying and to turn the
2214          BOTTOM_COND into an inequality test.  This should catch (almost) all
2215          loops with constant starting point.  If we cannot, we try to generate
2216          the default form, which is:
2217
2218            loop:
2219              TOP_COND
2220              BODY
2221              BOTTOM_UPDATE
2222              GOTO loop
2223
2224          It will be rotated during loop header copying and an entry test added
2225          to yield the do-while form.  This should catch (almost) all loops with
2226          constant ending point.  If we cannot, we generate the fallback form:
2227
2228              ENTRY_COND
2229            loop:
2230              BODY
2231              BOTTOM_COND
2232              BOTTOM_UPDATE
2233              GOTO loop
2234
2235          which works in all cases but for which loop header copying will copy
2236          the BOTTOM_COND, thus adding a third conditional branch.
2237
2238          If optimization is disabled, loop header copying doesn't come into
2239          play and we try to generate the loop forms with the less conditional
2240          branches directly.  First, the default form, it should catch (almost)
2241          all loops with constant ending point.  Then, if we cannot, we try to
2242          generate the shifted form:
2243
2244            loop:
2245              TOP_COND
2246              TOP_UPDATE
2247              BODY
2248              GOTO loop
2249
2250          which should catch loops with constant starting point.  Otherwise, if
2251          we cannot, we generate the fallback form.  */
2252
2253       if (optimize)
2254         {
2255           /* We can use the do-while form if GNU_FIRST-1 doesn't overflow.  */
2256           if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2257             {
2258               gnu_first = build_binary_op (shift_code, gnu_base_type,
2259                                            gnu_first, gnu_one_node);
2260               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2261               LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2262             }
2263
2264           /* Otherwise, we can use the default form if GNU_LAST+1 doesn't.  */
2265           else if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2266             ;
2267
2268           /* Otherwise, use the fallback form.  */
2269           else
2270             fallback = true;
2271         }
2272       else
2273         {
2274           /* We can use the default form if GNU_LAST+1 doesn't overflow.  */
2275           if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2276             ;
2277
2278           /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2279              GNU_LAST-1 does.  */
2280           else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2281                    && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2282             {
2283               gnu_first = build_binary_op (shift_code, gnu_base_type,
2284                                            gnu_first, gnu_one_node);
2285               gnu_last = build_binary_op (shift_code, gnu_base_type,
2286                                           gnu_last, gnu_one_node);
2287               LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2288             }
2289
2290           /* Otherwise, use the fallback form.  */
2291           else
2292             fallback = true;
2293         }
2294
2295       if (fallback)
2296         LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2297
2298       /* If we use the BOTTOM_COND, we can turn the test into an inequality
2299          test but we may have to add ENTRY_COND to protect the empty loop.  */
2300       if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2301         {
2302           test_code = NE_EXPR;
2303           if (can_be_lower_p (gnu_high, gnu_low))
2304             {
2305               gnu_cond_expr
2306                 = build3 (COND_EXPR, void_type_node,
2307                           build_binary_op (LE_EXPR, boolean_type_node,
2308                                            gnu_low, gnu_high),
2309                           NULL_TREE, alloc_stmt_list ());
2310               set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2311             }
2312         }
2313
2314       /* Open a new nesting level that will surround the loop to declare the
2315          iteration variable.  */
2316       start_stmt_group ();
2317       gnat_pushlevel ();
2318
2319       /* Declare the iteration variable and set it to its initial value.  */
2320       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2321       if (DECL_BY_REF_P (gnu_loop_var))
2322         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2323
2324       /* Do all the arithmetics in the base type.  */
2325       gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2326
2327       /* Set either the top or bottom exit condition.  */
2328       LOOP_STMT_COND (gnu_loop_stmt)
2329         = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2330                            gnu_last);
2331
2332       /* Set either the top or bottom update statement and give it the source
2333          location of the iteration for better coverage info.  */
2334       LOOP_STMT_UPDATE (gnu_loop_stmt)
2335         = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2336                            build_binary_op (update_code, gnu_base_type,
2337                                             gnu_loop_var, gnu_one_node));
2338       set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
2339                                    gnat_iter_scheme);
2340     }
2341
2342   /* If the loop was named, have the name point to this loop.  In this case,
2343      the association is not a DECL node, but the end label of the loop.  */
2344   if (Present (Identifier (gnat_node)))
2345     save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2346
2347   /* Make the loop body into its own block, so any allocated storage will be
2348      released every iteration.  This is needed for stack allocation.  */
2349   LOOP_STMT_BODY (gnu_loop_stmt)
2350     = build_stmt_group (Statements (gnat_node), true);
2351   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2352
2353   /* If we declared a variable, then we are in a statement group for that
2354      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
2355   if (gnu_loop_var)
2356     {
2357       add_stmt (gnu_loop_stmt);
2358       gnat_poplevel ();
2359       gnu_loop_stmt = end_stmt_group ();
2360     }
2361
2362   /* If we have an outer COND_EXPR, that's our result and this loop is its
2363      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2364   if (gnu_cond_expr)
2365     {
2366       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2367       gnu_result = gnu_cond_expr;
2368       recalculate_side_effects (gnu_cond_expr);
2369     }
2370   else
2371     gnu_result = gnu_loop_stmt;
2372
2373   VEC_pop (tree, gnu_loop_label_stack);
2374
2375   return gnu_result;
2376 }
2377 \f
2378 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2379    handler for the current function.  */
2380
2381 /* This is implemented by issuing a call to the appropriate VMS specific
2382    builtin.  To avoid having VMS specific sections in the global gigi decls
2383    array, we maintain the decls of interest here.  We can't declare them
2384    inside the function because we must mark them never to be GC'd, which we
2385    can only do at the global level.  */
2386
2387 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2388 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2389
2390 static void
2391 establish_gnat_vms_condition_handler (void)
2392 {
2393   tree establish_stmt;
2394
2395   /* Elaborate the required decls on the first call.  Check on the decl for
2396      the gnat condition handler to decide, as this is one we create so we are
2397      sure that it will be non null on subsequent calls.  The builtin decl is
2398      looked up so remains null on targets where it is not implemented yet.  */
2399   if (gnat_vms_condition_handler_decl == NULL_TREE)
2400     {
2401       vms_builtin_establish_handler_decl
2402         = builtin_decl_for
2403           (get_identifier ("__builtin_establish_vms_condition_handler"));
2404
2405       gnat_vms_condition_handler_decl
2406         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2407                                NULL_TREE,
2408                                build_function_type_list (boolean_type_node,
2409                                                          ptr_void_type_node,
2410                                                          ptr_void_type_node,
2411                                                          NULL_TREE),
2412                                NULL_TREE, 0, 1, 1, 0, Empty);
2413
2414       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2415       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2416     }
2417
2418   /* Do nothing if the establish builtin is not available, which might happen
2419      on targets where the facility is not implemented.  */
2420   if (vms_builtin_establish_handler_decl == NULL_TREE)
2421     return;
2422
2423   establish_stmt
2424     = build_call_1_expr (vms_builtin_establish_handler_decl,
2425                          build_unary_op
2426                          (ADDR_EXPR, NULL_TREE,
2427                           gnat_vms_condition_handler_decl));
2428
2429   add_stmt (establish_stmt);
2430 }
2431 \f
2432 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
2433    don't return anything.  */
2434
2435 static void
2436 Subprogram_Body_to_gnu (Node_Id gnat_node)
2437 {
2438   /* Defining identifier of a parameter to the subprogram.  */
2439   Entity_Id gnat_param;
2440   /* The defining identifier for the subprogram body. Note that if a
2441      specification has appeared before for this body, then the identifier
2442      occurring in that specification will also be a defining identifier and all
2443      the calls to this subprogram will point to that specification.  */
2444   Entity_Id gnat_subprog_id
2445     = (Present (Corresponding_Spec (gnat_node))
2446        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2447   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
2448   tree gnu_subprog_decl;
2449   /* Its RESULT_DECL node.  */
2450   tree gnu_result_decl;
2451   /* Its FUNCTION_TYPE node.  */
2452   tree gnu_subprog_type;
2453   /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any.  */
2454   tree gnu_cico_list;
2455   /* The entry in the CI_CO_LIST that represents a function return, if any.  */
2456   tree gnu_return_var_elmt = NULL_TREE;
2457   tree gnu_result;
2458   VEC(parm_attr,gc) *cache;
2459
2460   /* If this is a generic object or if it has been eliminated,
2461      ignore it.  */
2462   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2463       || Ekind (gnat_subprog_id) == E_Generic_Function
2464       || Is_Eliminated (gnat_subprog_id))
2465     return;
2466
2467   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
2468      the already-elaborated tree node.  However, if this subprogram had its
2469      elaboration deferred, we will already have made a tree node for it.  So
2470      treat it as not being defined in that case.  Such a subprogram cannot
2471      have an address clause or a freeze node, so this test is safe, though it
2472      does disable some otherwise-useful error checking.  */
2473   gnu_subprog_decl
2474     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2475                           Acts_As_Spec (gnat_node)
2476                           && !present_gnu_tree (gnat_subprog_id));
2477   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
2478   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2479   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2480   if (gnu_cico_list)
2481     gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list);
2482
2483   /* If the function returns by invisible reference, make it explicit in the
2484      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.
2485      Handle the explicit case here and the copy-in/copy-out case below.  */
2486   if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt)
2487     {
2488       TREE_TYPE (gnu_result_decl)
2489         = build_reference_type (TREE_TYPE (gnu_result_decl));
2490       relayout_decl (gnu_result_decl);
2491     }
2492
2493   /* Propagate the debug mode.  */
2494   if (!Needs_Debug_Info (gnat_subprog_id))
2495     DECL_IGNORED_P (gnu_subprog_decl) = 1;
2496
2497   /* Set the line number in the decl to correspond to that of the body so that
2498      the line number notes are written correctly.  */
2499   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
2500
2501   /* Initialize the information structure for the function.  */
2502   allocate_struct_function (gnu_subprog_decl, false);
2503   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
2504     = ggc_alloc_cleared_language_function ();
2505   set_cfun (NULL);
2506
2507   begin_subprog_body (gnu_subprog_decl);
2508
2509   /* If there are In Out or Out parameters, we need to ensure that the return
2510      statement properly copies them out.  We do this by making a new block and
2511      converting any return into a goto to a label at the end of the block.  */
2512   if (gnu_cico_list)
2513     {
2514       tree gnu_return_var = NULL_TREE;
2515
2516       VEC_safe_push (tree, gc, gnu_return_label_stack,
2517                      create_artificial_label (input_location));
2518
2519       start_stmt_group ();
2520       gnat_pushlevel ();
2521
2522       /* If this is a function with In Out or Out parameters, we also need a
2523          variable for the return value to be placed.  */
2524       if (gnu_return_var_elmt)
2525         {
2526           tree gnu_return_type
2527             = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
2528
2529           /* If the function returns by invisible reference, make it
2530              explicit in the function body.  See gnat_to_gnu_entity,
2531              E_Subprogram_Type case.  */
2532           if (TREE_ADDRESSABLE (gnu_subprog_type))
2533             gnu_return_type = build_reference_type (gnu_return_type);
2534
2535           gnu_return_var
2536             = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
2537                                gnu_return_type, NULL_TREE, false, false,
2538                                false, false, NULL, gnat_subprog_id);
2539           TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
2540         }
2541
2542       VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var);
2543
2544       /* See whether there are parameters for which we don't have a GCC tree
2545          yet.  These must be Out parameters.  Make a VAR_DECL for them and
2546          put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
2547          We can match up the entries because TYPE_CI_CO_LIST is in the order
2548          of the parameters.  */
2549       for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2550            Present (gnat_param);
2551            gnat_param = Next_Formal_With_Extras (gnat_param))
2552         if (!present_gnu_tree (gnat_param))
2553           {
2554             tree gnu_cico_entry = gnu_cico_list;
2555
2556             /* Skip any entries that have been already filled in; they must
2557                correspond to In Out parameters.  */
2558             while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
2559               gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
2560
2561             /* Do any needed references for padded types.  */
2562             TREE_VALUE (gnu_cico_entry)
2563               = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)),
2564                          gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2565           }
2566     }
2567   else
2568     VEC_safe_push (tree, gc, gnu_return_label_stack, NULL_TREE);
2569
2570   /* Get a tree corresponding to the code for the subprogram.  */
2571   start_stmt_group ();
2572   gnat_pushlevel ();
2573
2574   /* On VMS, establish our condition handler to possibly turn a condition into
2575      the corresponding exception if the subprogram has a foreign convention or
2576      is exported.
2577
2578      To ensure proper execution of local finalizations on condition instances,
2579      we must turn a condition into the corresponding exception even if there
2580      is no applicable Ada handler, and need at least one condition handler per
2581      possible call chain involving GNAT code.  OTOH, establishing the handler
2582      has a cost so we want to minimize the number of subprograms into which
2583      this happens.  The foreign or exported condition is expected to satisfy
2584      all the constraints.  */
2585   if (TARGET_ABI_OPEN_VMS
2586       && (Has_Foreign_Convention (gnat_subprog_id)
2587           || Is_Exported (gnat_subprog_id)))
2588     establish_gnat_vms_condition_handler ();
2589
2590   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
2591
2592   /* Generate the code of the subprogram itself.  A return statement will be
2593      present and any Out parameters will be handled there.  */
2594   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
2595   gnat_poplevel ();
2596   gnu_result = end_stmt_group ();
2597
2598   /* If we are dealing with a return from an Ada procedure with parameters
2599      passed by copy-in/copy-out, we need to return a record containing the
2600      final values of these parameters.  If the list contains only one entry,
2601      return just that entry though.
2602
2603      For a full description of the copy-in/copy-out parameter mechanism, see
2604      the part of the gnat_to_gnu_entity routine dealing with the translation
2605      of subprograms.
2606
2607      We need to make a block that contains the definition of that label and
2608      the copying of the return value.  It first contains the function, then
2609      the label and copy statement.  */
2610   if (gnu_cico_list)
2611     {
2612       tree gnu_retval;
2613
2614       add_stmt (gnu_result);
2615       add_stmt (build1 (LABEL_EXPR, void_type_node,
2616                         VEC_last (tree, gnu_return_label_stack)));
2617
2618       if (list_length (gnu_cico_list) == 1)
2619         gnu_retval = TREE_VALUE (gnu_cico_list);
2620       else
2621         gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
2622                                                   gnu_cico_list);
2623
2624       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
2625                           End_Label (Handled_Statement_Sequence (gnat_node)));
2626       gnat_poplevel ();
2627       gnu_result = end_stmt_group ();
2628     }
2629
2630   VEC_pop (tree, gnu_return_label_stack);
2631
2632   /* If we populated the parameter attributes cache, we need to make sure that
2633      the cached expressions are evaluated on all the possible paths leading to
2634      their uses.  So we force their evaluation on entry of the function.  */
2635   cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
2636   if (cache)
2637     {
2638       struct parm_attr_d *pa;
2639       int i;
2640
2641       start_stmt_group ();
2642
2643       FOR_EACH_VEC_ELT (parm_attr, cache, i, pa)
2644         {
2645           if (pa->first)
2646             add_stmt_with_node_force (pa->first, gnat_node);
2647           if (pa->last)
2648             add_stmt_with_node_force (pa->last, gnat_node);
2649           if (pa->length)
2650             add_stmt_with_node_force (pa->length, gnat_node);
2651         }
2652
2653       add_stmt (gnu_result);
2654       gnu_result = end_stmt_group ();
2655     }
2656
2657   /* Set the end location.  */
2658   Sloc_to_locus
2659     ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
2660       ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
2661       : Sloc (gnat_node)),
2662      &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
2663
2664   end_subprog_body (gnu_result);
2665
2666   /* Finally annotate the parameters and disconnect the trees for parameters
2667      that we have turned into variables since they are now unusable.  */
2668   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2669        Present (gnat_param);
2670        gnat_param = Next_Formal_With_Extras (gnat_param))
2671     {
2672       tree gnu_param = get_gnu_tree (gnat_param);
2673       bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
2674
2675       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
2676                        DECL_BY_REF_P (gnu_param),
2677                        !is_var_decl && DECL_BY_DOUBLE_REF_P (gnu_param));
2678
2679       if (is_var_decl)
2680         save_gnu_tree (gnat_param, NULL_TREE, false);
2681     }
2682
2683   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2684     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2685
2686   if (gnu_return_var_elmt)
2687     TREE_VALUE (gnu_return_var_elmt) = void_type_node;
2688
2689   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2690 }
2691 \f
2692
2693 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
2694    Put the initialization statement into GNU_INIT_STMT and annotate it with
2695    the SLOC of GNAT_NODE.  Return the temporary variable.  */
2696
2697 static tree
2698 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
2699                        Node_Id gnat_node)
2700 {
2701   tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
2702                                    TREE_TYPE (gnu_init), NULL_TREE, false,
2703                                    false, false, false, NULL, Empty);
2704   DECL_ARTIFICIAL (gnu_temp) = 1;
2705   DECL_IGNORED_P (gnu_temp) = 1;
2706
2707   *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
2708   set_expr_location_from_node (*gnu_init_stmt, gnat_node);
2709
2710   return gnu_temp;
2711 }
2712
2713 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2714    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2715    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2716    If GNU_TARGET is non-null, this must be a function call on the RHS of a
2717    N_Assignment_Statement and the result is to be placed into that object.  */
2718
2719 static tree
2720 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2721 {
2722   /* The GCC node corresponding to the GNAT subprogram name.  This can either
2723      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2724      or an indirect reference expression (an INDIRECT_REF node) pointing to a
2725      subprogram.  */
2726   tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
2727   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2728   tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
2729   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
2730   Entity_Id gnat_formal;
2731   Node_Id gnat_actual;
2732   VEC(tree,gc) *gnu_actual_vec = NULL;
2733   tree gnu_name_list = NULL_TREE;
2734   tree gnu_before_list = NULL_TREE;
2735   tree gnu_after_list = NULL_TREE;
2736   tree gnu_call, gnu_result;
2737   bool returning_value = (Nkind (gnat_node) == N_Function_Call && !gnu_target);
2738   bool pushed_binding_level = false;
2739   bool went_into_elab_proc = false;
2740
2741   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2742
2743   /* If we are calling a stubbed function, raise Program_Error, but Elaborate
2744      all our args first.  */
2745   if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
2746     {
2747       tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
2748                                          gnat_node, N_Raise_Program_Error);
2749
2750       for (gnat_actual = First_Actual (gnat_node);
2751            Present (gnat_actual);
2752            gnat_actual = Next_Actual (gnat_actual))
2753         add_stmt (gnat_to_gnu (gnat_actual));
2754
2755       if (returning_value)
2756         {
2757           *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
2758           return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr);
2759         }
2760
2761       return call_expr;
2762     }
2763
2764   /* The only way we can be making a call via an access type is if Name is an
2765      explicit dereference.  In that case, get the list of formal args from the
2766      type the access type is pointing to.  Otherwise, get the formals from the
2767      entity being called.  */
2768   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2769     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2770   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2771     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2772     gnat_formal = Empty;
2773   else
2774     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2775
2776   /* If we are translating a statement, push a new binding level that will
2777      surround it to declare the temporaries created for the call.  Likewise
2778      if we'll be returning a value and also have copy-in/copy-out parameters,
2779      as we need to create statements to fetch their value after the call.
2780
2781      ??? We could do that unconditionally, but the middle-end doesn't seem
2782      to be prepared to handle the construct in nested contexts.  */
2783   if (!returning_value || TYPE_CI_CO_LIST (gnu_subprog_type))
2784     {
2785       start_stmt_group ();
2786       gnat_pushlevel ();
2787       pushed_binding_level = true;
2788     }
2789
2790   /* The lifetime of the temporaries created for the call ends with the call
2791      so we can give them the scope of the elaboration routine at top level.  */
2792   if (!current_function_decl)
2793     {
2794       current_function_decl = get_elaboration_procedure ();
2795       went_into_elab_proc = true;
2796     }
2797
2798   /* Create the list of the actual parameters as GCC expects it, namely a
2799      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
2800      is an expression and the TREE_PURPOSE field is null.  But skip Out
2801      parameters not passed by reference and that need not be copied in.  */
2802   for (gnat_actual = First_Actual (gnat_node);
2803        Present (gnat_actual);
2804        gnat_formal = Next_Formal_With_Extras (gnat_formal),
2805        gnat_actual = Next_Actual (gnat_actual))
2806     {
2807       tree gnu_formal = present_gnu_tree (gnat_formal)
2808                         ? get_gnu_tree (gnat_formal) : NULL_TREE;
2809       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2810       /* In the Out or In Out case, we must suppress conversions that yield
2811          an lvalue but can nevertheless cause the creation of a temporary,
2812          because we need the real object in this case, either to pass its
2813          address if it's passed by reference or as target of the back copy
2814          done after the call if it uses the copy-in copy-out mechanism.
2815          We do it in the In case too, except for an unchecked conversion
2816          because it alone can cause the actual to be misaligned and the
2817          addressability test is applied to the real object.  */
2818       bool suppress_type_conversion
2819         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2820             && Ekind (gnat_formal) != E_In_Parameter)
2821            || (Nkind (gnat_actual) == N_Type_Conversion
2822                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2823       Node_Id gnat_name = suppress_type_conversion
2824                           ? Expression (gnat_actual) : gnat_actual;
2825       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2826       tree gnu_actual;
2827
2828       /* If it's possible we may need to use this expression twice, make sure
2829          that any side-effects are handled via SAVE_EXPRs; likewise if we need
2830          to force side-effects before the call.
2831          ??? This is more conservative than we need since we don't need to do
2832          this for pass-by-ref with no conversion.  */
2833       if (Ekind (gnat_formal) != E_In_Parameter)
2834         gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
2835
2836       /* If we are passing a non-addressable parameter by reference, pass the
2837          address of a copy.  In the Out or In Out case, set up to copy back
2838          out after the call.  */
2839       if (gnu_formal
2840           && (DECL_BY_REF_P (gnu_formal)
2841               || (TREE_CODE (gnu_formal) == PARM_DECL
2842                   && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2843                       || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2844           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2845           && !addressable_p (gnu_name, gnu_name_type))
2846         {
2847           bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
2848           tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
2849
2850           /* Do not issue warnings for CONSTRUCTORs since this is not a copy
2851              but sort of an instantiation for them.  */
2852           if (TREE_CODE (gnu_name) == CONSTRUCTOR)
2853             ;
2854
2855           /* If the type is passed by reference, a copy is not allowed.  */
2856           else if (TREE_ADDRESSABLE (gnu_formal_type))
2857             post_error ("misaligned actual cannot be passed by reference",
2858                         gnat_actual);
2859
2860           /* For users of Starlet we issue a warning because the interface
2861              apparently assumes that by-ref parameters outlive the procedure
2862              invocation.  The code still will not work as intended, but we
2863              cannot do much better since low-level parts of the back-end
2864              would allocate temporaries at will because of the misalignment
2865              if we did not do so here.  */
2866           else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2867             {
2868               post_error
2869                 ("?possible violation of implicit assumption", gnat_actual);
2870               post_error_ne
2871                 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
2872                  Entity (Name (gnat_node)));
2873               post_error_ne ("?because of misalignment of &", gnat_actual,
2874                              gnat_formal);
2875             }
2876
2877           /* If the actual type of the object is already the nominal type,
2878              we have nothing to do, except if the size is self-referential
2879              in which case we'll remove the unpadding below.  */
2880           if (TREE_TYPE (gnu_name) == gnu_name_type
2881               && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
2882             ;
2883
2884           /* Otherwise remove the unpadding from all the objects.  */
2885           else if (TREE_CODE (gnu_name) == COMPONENT_REF
2886                    && TYPE_IS_PADDING_P
2887                       (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
2888             gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
2889
2890           /* Otherwise convert to the nominal type of the object if needed.
2891              There are several cases in which we need to make the temporary
2892              using this type instead of the actual type of the object when
2893              they are distinct, because the expectations of the callee would
2894              otherwise not be met:
2895                - if it's a justified modular type,
2896                - if the actual type is a smaller form of it,
2897                - if it's a smaller form of the actual type.  */
2898           else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
2899                     && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
2900                         || smaller_form_type_p (TREE_TYPE (gnu_name),
2901                                                 gnu_name_type)))
2902                    || (INTEGRAL_TYPE_P (gnu_name_type)
2903                        && smaller_form_type_p (gnu_name_type,
2904                                                TREE_TYPE (gnu_name))))
2905             gnu_name = convert (gnu_name_type, gnu_name);
2906
2907           /* If we haven't pushed a binding level and this is an In Out or Out
2908              parameter, push a new one.  This is needed to wrap the copy-back
2909              statements we'll be making below.  */
2910           if (!pushed_binding_level && !in_param)
2911             {
2912               start_stmt_group ();
2913               gnat_pushlevel ();
2914               pushed_binding_level = true;
2915             }
2916
2917           /* Create an explicit temporary holding the copy.  This ensures that
2918              its lifetime is as narrow as possible around a statement.  */
2919           gnu_temp
2920             = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
2921
2922           /* But initialize it on the fly like for an implicit temporary as
2923              we aren't necessarily dealing with a statement.  */
2924           gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
2925                                           gnu_temp);
2926
2927           /* Set up to move the copy back to the original if needed.  */
2928           if (!in_param)
2929             {
2930               gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
2931                                           gnu_temp);
2932               set_expr_location_from_node (gnu_stmt, gnat_node);
2933               append_to_statement_list (gnu_stmt, &gnu_after_list);
2934             }
2935         }
2936
2937       /* Start from the real object and build the actual.  */
2938       gnu_actual = gnu_name;
2939
2940       /* If this was a procedure call, we may not have removed any padding.
2941          So do it here for the part we will use as an input, if any.  */
2942       if (Ekind (gnat_formal) != E_Out_Parameter
2943           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2944         gnu_actual
2945           = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
2946
2947       /* Put back the conversion we suppressed above in the computation of the
2948          real object.  And even if we didn't suppress any conversion there, we
2949          may have suppressed a conversion to the Etype of the actual earlier,
2950          since the parent is a procedure call, so put it back here.  */
2951       if (suppress_type_conversion
2952           && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2953         gnu_actual
2954           = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2955                                gnu_actual, No_Truncation (gnat_actual));
2956       else
2957         gnu_actual
2958           = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
2959
2960       /* Make sure that the actual is in range of the formal's type.  */
2961       if (Ekind (gnat_formal) != E_Out_Parameter
2962           && Do_Range_Check (gnat_actual))
2963         gnu_actual
2964           = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
2965
2966       /* Unless this is an In parameter, we must remove any justified modular
2967          building from GNU_NAME to get an lvalue.  */
2968       if (Ekind (gnat_formal) != E_In_Parameter
2969           && TREE_CODE (gnu_name) == CONSTRUCTOR
2970           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2971           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2972         gnu_name
2973           = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
2974
2975       /* If we have not saved a GCC object for the formal, it means it is an
2976          Out parameter not passed by reference and that need not be copied in.
2977          Otherwise, first see if the parameter is passed by reference.  */
2978       if (gnu_formal
2979           && TREE_CODE (gnu_formal) == PARM_DECL
2980           && DECL_BY_REF_P (gnu_formal))
2981         {
2982           if (Ekind (gnat_formal) != E_In_Parameter)
2983             {
2984               /* In Out or Out parameters passed by reference don't use the
2985                  copy-in copy-out mechanism so the address of the real object
2986                  must be passed to the function.  */
2987               gnu_actual = gnu_name;
2988
2989               /* If we have a padded type, be sure we've removed padding.  */
2990               if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2991                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2992                                       gnu_actual);
2993
2994               /* If we have the constructed subtype of an aliased object
2995                  with an unconstrained nominal subtype, the type of the
2996                  actual includes the template, although it is formally
2997                  constrained.  So we need to convert it back to the real
2998                  constructed subtype to retrieve the constrained part
2999                  and takes its address.  */
3000               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
3001                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
3002                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
3003                   && Is_Array_Type (Etype (gnat_actual)))
3004                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
3005                                       gnu_actual);
3006             }
3007
3008           /* There is no need to convert the actual to the formal's type before
3009              taking its address.  The only exception is for unconstrained array
3010              types because of the way we build fat pointers.  */
3011           else if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
3012             gnu_actual = convert (gnu_formal_type, gnu_actual);
3013
3014           /* The symmetry of the paths to the type of an entity is broken here
3015              since arguments don't know that they will be passed by ref.  */
3016           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3017
3018           if (DECL_BY_DOUBLE_REF_P (gnu_formal))
3019             gnu_actual
3020               = build_unary_op (ADDR_EXPR, TREE_TYPE (gnu_formal_type),
3021                                 gnu_actual);
3022
3023           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
3024         }
3025       else if (gnu_formal
3026                && TREE_CODE (gnu_formal) == PARM_DECL
3027                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
3028         {
3029           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3030           gnu_actual = maybe_implicit_deref (gnu_actual);
3031           gnu_actual = maybe_unconstrained_array (gnu_actual);
3032
3033           if (TYPE_IS_PADDING_P (gnu_formal_type))
3034             {
3035               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
3036               gnu_actual = convert (gnu_formal_type, gnu_actual);
3037             }
3038
3039           /* Take the address of the object and convert to the proper pointer
3040              type.  We'd like to actually compute the address of the beginning
3041              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
3042              possibility that the ARRAY_REF might return a constant and we'd be
3043              getting the wrong address.  Neither approach is exactly correct,
3044              but this is the most likely to work in all cases.  */
3045           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
3046         }
3047       else if (gnu_formal
3048                && TREE_CODE (gnu_formal) == PARM_DECL
3049                && DECL_BY_DESCRIPTOR_P (gnu_formal))
3050         {
3051           gnu_actual = convert (gnu_formal_type, gnu_actual);
3052
3053           /* If this is 'Null_Parameter, pass a zero descriptor.  */
3054           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
3055                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
3056               && TREE_PRIVATE (gnu_actual))
3057             gnu_actual
3058               = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
3059           else
3060             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
3061                                          fill_vms_descriptor (gnu_actual,
3062                                                               gnat_formal,
3063                                                               gnat_actual));
3064         }
3065       else
3066         {
3067           tree gnu_size;
3068
3069           if (Ekind (gnat_formal) != E_In_Parameter)
3070             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
3071
3072           if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
3073             {
3074               /* Make sure side-effects are evaluated before the call.  */
3075               if (TREE_SIDE_EFFECTS (gnu_name))
3076                 append_to_statement_list (gnu_name, &gnu_before_list);
3077               continue;
3078             }
3079
3080           gnu_actual = convert (gnu_formal_type, gnu_actual);
3081
3082           /* If this is 'Null_Parameter, pass a zero even though we are
3083              dereferencing it.  */
3084           if (TREE_CODE (gnu_actual) == INDIRECT_REF
3085               && TREE_PRIVATE (gnu_actual)
3086               && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
3087               && TREE_CODE (gnu_size) == INTEGER_CST
3088               && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
3089             gnu_actual
3090               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
3091                                    convert (gnat_type_for_size
3092                                             (TREE_INT_CST_LOW (gnu_size), 1),
3093                                             integer_zero_node),
3094                                    false);
3095           else
3096             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
3097         }
3098
3099       VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual);
3100     }
3101
3102   gnu_call = build_call_vec (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr,
3103                              gnu_actual_vec);
3104   set_expr_location_from_node (gnu_call, gnat_node);
3105
3106   /* If this is a subprogram with copy-in/copy-out parameters, we need to
3107      unpack the valued returned from the function into the In Out or Out
3108      parameters.  We deal with the function return (if this is an Ada
3109      function) below.  */
3110   if (TYPE_CI_CO_LIST (gnu_subprog_type))
3111     {
3112       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
3113          copy-out parameters.  */
3114       tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3115       const int length = list_length (gnu_cico_list);
3116
3117       /* The call sequence must contain one and only one call, even though the
3118          function is pure.  Save the result into a temporary if needed.  */
3119       if (length > 1)
3120         {
3121           tree gnu_stmt;
3122           gnu_call
3123             = create_init_temporary ("R", gnu_call, &gnu_stmt, gnat_node);
3124           append_to_statement_list (gnu_stmt, &gnu_before_list);
3125
3126           gnu_name_list = nreverse (gnu_name_list);
3127         }
3128
3129       /* The first entry is for the actual return value if this is a
3130          function, so skip it.  */
3131       if (TREE_VALUE (gnu_cico_list) == void_type_node)
3132         gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3133
3134       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3135         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
3136       else
3137         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
3138
3139       for (gnat_actual = First_Actual (gnat_node);
3140            Present (gnat_actual);
3141            gnat_formal = Next_Formal_With_Extras (gnat_formal),
3142            gnat_actual = Next_Actual (gnat_actual))
3143         /* If we are dealing with a copy-in/copy-out parameter, we must
3144            retrieve its value from the record returned in the call.  */
3145         if (!(present_gnu_tree (gnat_formal)
3146               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3147               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
3148                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3149                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
3150                            || (DECL_BY_DESCRIPTOR_P
3151                                (get_gnu_tree (gnat_formal))))))))
3152             && Ekind (gnat_formal) != E_In_Parameter)
3153           {
3154             /* Get the value to assign to this Out or In Out parameter.  It is
3155                either the result of the function if there is only a single such
3156                parameter or the appropriate field from the record returned.  */
3157             tree gnu_result
3158               = length == 1
3159                 ? gnu_call
3160                 : build_component_ref (gnu_call, NULL_TREE,
3161                                        TREE_PURPOSE (gnu_cico_list), false);
3162
3163             /* If the actual is a conversion, get the inner expression, which
3164                will be the real destination, and convert the result to the
3165                type of the actual parameter.  */
3166             tree gnu_actual
3167               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3168
3169             /* If the result is a padded type, remove the padding.  */
3170             if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3171               gnu_result
3172                 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
3173                            gnu_result);
3174
3175             /* If the actual is a type conversion, the real target object is
3176                denoted by the inner Expression and we need to convert the
3177                result to the associated type.
3178                We also need to convert our gnu assignment target to this type
3179                if the corresponding GNU_NAME was constructed from the GNAT
3180                conversion node and not from the inner Expression.  */
3181             if (Nkind (gnat_actual) == N_Type_Conversion)
3182               {
3183                 gnu_result
3184                   = convert_with_check
3185                     (Etype (Expression (gnat_actual)), gnu_result,
3186                      Do_Overflow_Check (gnat_actual),
3187                      Do_Range_Check (Expression (gnat_actual)),
3188                      Float_Truncate (gnat_actual), gnat_actual);
3189
3190                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
3191                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
3192               }
3193
3194             /* Unchecked conversions as actuals for Out parameters are not
3195                allowed in user code because they are not variables, but do
3196                occur in front-end expansions.  The associated GNU_NAME is
3197                always obtained from the inner expression in such cases.  */
3198             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
3199               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
3200                                               gnu_result,
3201                                               No_Truncation (gnat_actual));
3202             else
3203               {
3204                 if (Do_Range_Check (gnat_actual))
3205                   gnu_result
3206                     = emit_range_check (gnu_result, Etype (gnat_actual),
3207                                         gnat_actual);
3208
3209                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
3210                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
3211                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
3212               }
3213
3214             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3215                                           gnu_actual, gnu_result);
3216             set_expr_location_from_node (gnu_result, gnat_node);
3217             append_to_statement_list (gnu_result, &gnu_before_list);
3218             gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3219             gnu_name_list = TREE_CHAIN (gnu_name_list);
3220           }
3221     }
3222
3223   /* If this is a function call, the result is the call expression unless a
3224      target is specified, in which case we copy the result into the target
3225      and return the assignment statement.  */
3226   if (Nkind (gnat_node) == N_Function_Call)
3227     {
3228       tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
3229
3230       /* If this is a function with copy-in/copy-out parameters, extract the
3231          return value from it and update the return type.  */
3232       if (TYPE_CI_CO_LIST (gnu_subprog_type))
3233         {
3234           tree gnu_elmt = value_member (void_type_node,
3235                                         TYPE_CI_CO_LIST (gnu_subprog_type));
3236           gnu_call = build_component_ref (gnu_call, NULL_TREE,
3237                                           TREE_PURPOSE (gnu_elmt), false);
3238           gnu_result_type = TREE_TYPE (gnu_call);
3239         }
3240
3241       /* If the function returns an unconstrained array or by direct reference,
3242          we have to dereference the pointer.  */
3243       if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
3244           || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
3245         gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
3246
3247       if (gnu_target)
3248         {
3249           Node_Id gnat_parent = Parent (gnat_node);
3250           enum tree_code op_code;
3251
3252           /* If range check is needed, emit code to generate it.  */
3253           if (Do_Range_Check (gnat_node))
3254             gnu_call
3255               = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
3256                                   gnat_parent);
3257
3258           /* ??? If the return type has non-constant size, then force the
3259              return slot optimization as we would not be able to generate
3260              a temporary.  Likewise if it was unconstrained as we would
3261              copy too much data.  That's what has been done historically.  */
3262           if (!TREE_CONSTANT (TYPE_SIZE (gnu_result_type))
3263               || (TYPE_IS_PADDING_P (gnu_result_type)
3264                   && CONTAINS_PLACEHOLDER_P
3265                      (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type))))))
3266             op_code = INIT_EXPR;
3267           else
3268             op_code = MODIFY_EXPR;
3269
3270           gnu_call
3271             = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
3272           set_expr_location_from_node (gnu_call, gnat_parent);
3273           append_to_statement_list (gnu_call, &gnu_before_list);
3274         }
3275       else
3276         *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
3277     }
3278
3279   /* Otherwise, if this is a procedure call statement without copy-in/copy-out
3280      parameters, the result is just the call statement.  */
3281   else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
3282     append_to_statement_list (gnu_call, &gnu_before_list);
3283
3284   if (went_into_elab_proc)
3285     current_function_decl = NULL_TREE;
3286
3287   /* If we have pushed a binding level, the result is the statement group.
3288      Otherwise it's just the call expression.  */
3289   if (pushed_binding_level)
3290     {
3291       /* If we need a value and haven't created the call statement, do so.  */
3292       if (returning_value && !TYPE_CI_CO_LIST (gnu_subprog_type))
3293         {
3294           tree gnu_stmt;
3295           gnu_call
3296             = create_init_temporary ("R", gnu_call, &gnu_stmt, gnat_node);
3297           append_to_statement_list (gnu_stmt, &gnu_before_list);
3298         }
3299       append_to_statement_list (gnu_after_list, &gnu_before_list);
3300       add_stmt (gnu_before_list);
3301       gnat_poplevel ();
3302       gnu_result = end_stmt_group ();
3303     }
3304   else
3305     return gnu_call;
3306
3307   /* If we need a value, make a COMPOUND_EXPR to return it; otherwise,
3308      return the result.  Deal specially with UNCONSTRAINED_ARRAY_REF.  */
3309   if (returning_value)
3310     gnu_result = build_compound_expr (TREE_TYPE (gnu_call), gnu_result,
3311                                       gnu_call);
3312
3313   return gnu_result;
3314 }
3315 \f
3316 /* Subroutine of gnat_to_gnu to translate gnat_node, an
3317    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
3318
3319 static tree
3320 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
3321 {
3322   tree gnu_jmpsave_decl = NULL_TREE;
3323   tree gnu_jmpbuf_decl = NULL_TREE;
3324   /* If just annotating, ignore all EH and cleanups.  */
3325   bool gcc_zcx = (!type_annotate_only
3326                   && Present (Exception_Handlers (gnat_node))
3327                   && Exception_Mechanism == Back_End_Exceptions);
3328   bool setjmp_longjmp
3329     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
3330        && Exception_Mechanism == Setjmp_Longjmp);
3331   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
3332   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
3333   tree gnu_inner_block; /* The statement(s) for the block itself.  */
3334   tree gnu_result;
3335   tree gnu_expr;
3336   Node_Id gnat_temp;
3337
3338   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
3339      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
3340      add_cleanup, and when we leave the binding, end_stmt_group will create
3341      the TRY_FINALLY_EXPR.
3342
3343      ??? The region level calls down there have been specifically put in place
3344      for a ZCX context and currently the order in which things are emitted
3345      (region/handlers) is different from the SJLJ case. Instead of putting
3346      other calls with different conditions at other places for the SJLJ case,
3347      it seems cleaner to reorder things for the SJLJ case and generalize the
3348      condition to make it not ZCX specific.
3349
3350      If there are any exceptions or cleanup processing involved, we need an
3351      outer statement group (for Setjmp_Longjmp) and binding level.  */
3352   if (binding_for_block)
3353     {
3354       start_stmt_group ();
3355       gnat_pushlevel ();
3356     }
3357
3358   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
3359      area for address of previous buffer.  Do this first since we need to have
3360      the setjmp buf known for any decls in this block.  */
3361   if (setjmp_longjmp)
3362     {
3363       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
3364                                           NULL_TREE, jmpbuf_ptr_type,
3365                                           build_call_0_expr (get_jmpbuf_decl),
3366                                           false, false, false, false,
3367                                           NULL, gnat_node);
3368       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
3369
3370       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
3371          because of the unstructured form of EH used by setjmp_longjmp, there
3372          might be forward edges going to __builtin_setjmp receivers on which
3373          it is uninitialized, although they will never be actually taken.  */
3374       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
3375       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
3376                                          NULL_TREE, jmpbuf_type, NULL_TREE,
3377                                          false, false, false, false,
3378                                          NULL, gnat_node);
3379       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
3380
3381       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
3382
3383       /* When we exit this block, restore the saved value.  */
3384       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
3385                    End_Label (gnat_node));
3386     }
3387
3388   /* If we are to call a function when exiting this block, add a cleanup
3389      to the binding level we made above.  Note that add_cleanup is FIFO
3390      so we must register this cleanup after the EH cleanup just above.  */
3391   if (at_end)
3392     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
3393                  End_Label (gnat_node));
3394
3395   /* Now build the tree for the declarations and statements inside this block.
3396      If this is SJLJ, set our jmp_buf as the current buffer.  */
3397   start_stmt_group ();
3398
3399   if (setjmp_longjmp)
3400     add_stmt (build_call_1_expr (set_jmpbuf_decl,
3401                                  build_unary_op (ADDR_EXPR, NULL_TREE,
3402                                                  gnu_jmpbuf_decl)));
3403
3404   if (Present (First_Real_Statement (gnat_node)))
3405     process_decls (Statements (gnat_node), Empty,
3406                    First_Real_Statement (gnat_node), true, true);
3407
3408   /* Generate code for each statement in the block.  */
3409   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3410                     ? First_Real_Statement (gnat_node)
3411                     : First (Statements (gnat_node)));
3412        Present (gnat_temp); gnat_temp = Next (gnat_temp))
3413     add_stmt (gnat_to_gnu (gnat_temp));
3414   gnu_inner_block = end_stmt_group ();
3415
3416   /* Now generate code for the two exception models, if either is relevant for
3417      this block.  */
3418   if (setjmp_longjmp)
3419     {
3420       tree *gnu_else_ptr = 0;
3421       tree gnu_handler;
3422
3423       /* Make a binding level for the exception handling declarations and code
3424          and set up gnu_except_ptr_stack for the handlers to use.  */
3425       start_stmt_group ();
3426       gnat_pushlevel ();
3427
3428       VEC_safe_push (tree, gc, gnu_except_ptr_stack,
3429                      create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
3430                                       build_pointer_type (except_type_node),
3431                                       build_call_0_expr (get_excptr_decl),
3432                                       false, false, false, false,
3433                                       NULL, gnat_node));
3434
3435       /* Generate code for each handler. The N_Exception_Handler case does the
3436          real work and returns a COND_EXPR for each handler, which we chain
3437          together here.  */
3438       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3439            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
3440         {
3441           gnu_expr = gnat_to_gnu (gnat_temp);
3442
3443           /* If this is the first one, set it as the outer one. Otherwise,
3444              point the "else" part of the previous handler to us. Then point
3445              to our "else" part.  */
3446           if (!gnu_else_ptr)
3447             add_stmt (gnu_expr);
3448           else
3449             *gnu_else_ptr = gnu_expr;
3450
3451           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3452         }
3453
3454       /* If none of the exception handlers did anything, re-raise but do not
3455          defer abortion.  */
3456       gnu_expr = build_call_1_expr (raise_nodefer_decl,
3457                                     VEC_last (tree, gnu_except_ptr_stack));
3458       set_expr_location_from_node
3459         (gnu_expr,
3460          Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
3461
3462       if (gnu_else_ptr)
3463         *gnu_else_ptr = gnu_expr;
3464       else
3465         add_stmt (gnu_expr);
3466
3467       /* End the binding level dedicated to the exception handlers and get the
3468          whole statement group.  */
3469       VEC_pop (tree, gnu_except_ptr_stack);
3470       gnat_poplevel ();
3471       gnu_handler = end_stmt_group ();
3472
3473       /* If the setjmp returns 1, we restore our incoming longjmp value and
3474          then check the handlers.  */
3475       start_stmt_group ();
3476       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
3477                                              gnu_jmpsave_decl),
3478                           gnat_node);
3479       add_stmt (gnu_handler);
3480       gnu_handler = end_stmt_group ();
3481
3482       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
3483       gnu_result = build3 (COND_EXPR, void_type_node,
3484                            (build_call_1_expr
3485                             (setjmp_decl,
3486                              build_unary_op (ADDR_EXPR, NULL_TREE,
3487                                              gnu_jmpbuf_decl))),
3488                            gnu_handler, gnu_inner_block);
3489     }
3490   else if (gcc_zcx)
3491     {
3492       tree gnu_handlers;
3493
3494       /* First make a block containing the handlers.  */
3495       start_stmt_group ();
3496       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3497            Present (gnat_temp);
3498            gnat_temp = Next_Non_Pragma (gnat_temp))
3499         add_stmt (gnat_to_gnu (gnat_temp));
3500       gnu_handlers = end_stmt_group ();
3501
3502       /* Now make the TRY_CATCH_EXPR for the block.  */
3503       gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
3504                            gnu_inner_block, gnu_handlers);
3505     }
3506   else
3507     gnu_result = gnu_inner_block;
3508
3509   /* Now close our outer block, if we had to make one.  */
3510   if (binding_for_block)
3511     {
3512       add_stmt (gnu_result);
3513       gnat_poplevel ();
3514       gnu_result = end_stmt_group ();
3515     }
3516
3517   return gnu_result;
3518 }
3519 \f
3520 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3521    to a GCC tree, which is returned.  This is the variant for Setjmp_Longjmp
3522    exception handling.  */
3523
3524 static tree
3525 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
3526 {
3527   /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
3528      an "if" statement to select the proper exceptions.  For "Others", exclude
3529      exceptions where Handled_By_Others is nonzero unless the All_Others flag
3530      is set. For "Non-ada", accept an exception if "Lang" is 'V'.  */
3531   tree gnu_choice = integer_zero_node;
3532   tree gnu_body = build_stmt_group (Statements (gnat_node), false);
3533   Node_Id gnat_temp;
3534
3535   for (gnat_temp = First (Exception_Choices (gnat_node));
3536        gnat_temp; gnat_temp = Next (gnat_temp))
3537     {
3538       tree this_choice;
3539
3540       if (Nkind (gnat_temp) == N_Others_Choice)
3541         {
3542           if (All_Others (gnat_temp))
3543             this_choice = integer_one_node;
3544           else
3545             this_choice
3546               = build_binary_op
3547                 (EQ_EXPR, boolean_type_node,
3548                  convert
3549                  (integer_type_node,
3550                   build_component_ref
3551                   (build_unary_op
3552                    (INDIRECT_REF, NULL_TREE,
3553                     VEC_last (tree, gnu_except_ptr_stack)),
3554                    get_identifier ("not_handled_by_others"), NULL_TREE,
3555                    false)),
3556                  integer_zero_node);
3557         }
3558
3559       else if (Nkind (gnat_temp) == N_Identifier
3560                || Nkind (gnat_temp) == N_Expanded_Name)
3561         {
3562           Entity_Id gnat_ex_id = Entity (gnat_temp);
3563           tree gnu_expr;
3564
3565           /* Exception may be a renaming. Recover original exception which is
3566              the one elaborated and registered.  */
3567           if (Present (Renamed_Object (gnat_ex_id)))
3568             gnat_ex_id = Renamed_Object (gnat_ex_id);
3569
3570           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3571
3572           this_choice
3573             = build_binary_op
3574               (EQ_EXPR, boolean_type_node,
3575                VEC_last (tree, gnu_except_ptr_stack),
3576                convert (TREE_TYPE (VEC_last (tree, gnu_except_ptr_stack)),
3577                         build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3578
3579           /* If this is the distinguished exception "Non_Ada_Error" (and we are
3580              in VMS mode), also allow a non-Ada exception (a VMS condition) t
3581              match.  */
3582           if (Is_Non_Ada_Error (Entity (gnat_temp)))
3583             {
3584               tree gnu_comp
3585                 = build_component_ref
3586                   (build_unary_op (INDIRECT_REF, NULL_TREE,
3587                                    VEC_last (tree, gnu_except_ptr_stack)),
3588                    get_identifier ("lang"), NULL_TREE, false);
3589
3590               this_choice
3591                 = build_binary_op
3592                   (TRUTH_ORIF_EXPR, boolean_type_node,
3593                    build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp,
3594                                     build_int_cst (TREE_TYPE (gnu_comp), 'V')),
3595                    this_choice);
3596             }
3597         }
3598       else
3599         gcc_unreachable ();
3600
3601       gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
3602                                     gnu_choice, this_choice);
3603     }
3604
3605   return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
3606 }
3607 \f
3608 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3609    to a GCC tree, which is returned.  This is the variant for ZCX.  */
3610
3611 static tree
3612 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
3613 {
3614   tree gnu_etypes_list = NULL_TREE;
3615   tree gnu_expr;
3616   tree gnu_etype;
3617   tree gnu_current_exc_ptr;
3618   tree gnu_incoming_exc_ptr;
3619   Node_Id gnat_temp;
3620
3621   /* We build a TREE_LIST of nodes representing what exception types this
3622      handler can catch, with special cases for others and all others cases.
3623
3624      Each exception type is actually identified by a pointer to the exception
3625      id, or to a dummy object for "others" and "all others".  */
3626   for (gnat_temp = First (Exception_Choices (gnat_node));
3627        gnat_temp; gnat_temp = Next (gnat_temp))
3628     {
3629       if (Nkind (gnat_temp) == N_Others_Choice)
3630         {
3631           tree gnu_expr
3632             = All_Others (gnat_temp) ? all_others_decl : others_decl;
3633
3634           gnu_etype
3635             = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3636         }
3637       else if (Nkind (gnat_temp) == N_Identifier
3638                || Nkind (gnat_temp) == N_Expanded_Name)
3639         {
3640           Entity_Id gnat_ex_id = Entity (gnat_temp);
3641
3642           /* Exception may be a renaming. Recover original exception which is
3643              the one elaborated and registered.  */
3644           if (Present (Renamed_Object (gnat_ex_id)))
3645             gnat_ex_id = Renamed_Object (gnat_ex_id);
3646
3647           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3648           gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3649
3650           /* The Non_Ada_Error case for VMS exceptions is handled
3651              by the personality routine.  */
3652         }
3653       else
3654         gcc_unreachable ();
3655
3656       /* The GCC interface expects NULL to be passed for catch all handlers, so
3657          it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
3658          is integer_zero_node.  It would not work, however, because GCC's
3659          notion of "catch all" is stronger than our notion of "others".  Until
3660          we correctly use the cleanup interface as well, doing that would
3661          prevent the "all others" handlers from being seen, because nothing
3662          can be caught beyond a catch all from GCC's point of view.  */
3663       gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3664     }
3665
3666   start_stmt_group ();
3667   gnat_pushlevel ();
3668
3669   /* Expand a call to the begin_handler hook at the beginning of the handler,
3670      and arrange for a call to the end_handler hook to occur on every possible
3671      exit path.
3672
3673      The hooks expect a pointer to the low level occurrence. This is required
3674      for our stack management scheme because a raise inside the handler pushes
3675      a new occurrence on top of the stack, which means that this top does not
3676      necessarily match the occurrence this handler was dealing with.
3677
3678      __builtin_eh_pointer references the exception occurrence being
3679      propagated. Upon handler entry, this is the exception for which the
3680      handler is triggered. This might not be the case upon handler exit,
3681      however, as we might have a new occurrence propagated by the handler's
3682      body, and the end_handler hook called as a cleanup in this context.
3683
3684      We use a local variable to retrieve the incoming value at handler entry
3685      time, and reuse it to feed the end_handler hook's argument at exit.  */
3686
3687   gnu_current_exc_ptr
3688     = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
3689                        1, integer_zero_node);
3690   gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3691                                           ptr_type_node, gnu_current_exc_ptr,
3692                                           false, false, false, false,
3693                                           NULL, gnat_node);
3694
3695   add_stmt_with_node (build_call_1_expr (begin_handler_decl,
3696                                          gnu_incoming_exc_ptr),
3697                       gnat_node);
3698   /* ??? We don't seem to have an End_Label at hand to set the location.  */
3699   add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
3700                Empty);
3701   add_stmt_list (Statements (gnat_node));
3702   gnat_poplevel ();
3703
3704   return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
3705                  end_stmt_group ());
3706 }
3707 \f
3708 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
3709
3710 static void
3711 Compilation_Unit_to_gnu (Node_Id gnat_node)
3712 {
3713   const Node_Id gnat_unit = Unit (gnat_node);
3714   const bool body_p = (Nkind (gnat_unit) == N_Package_Body
3715                        || Nkind (gnat_unit) == N_Subprogram_Body);
3716   const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
3717   /* Make the decl for the elaboration procedure.  */
3718   tree gnu_elab_proc_decl
3719     = create_subprog_decl
3720       (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
3721        NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, gnat_unit);
3722   struct elab_info *info;
3723
3724   VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl);
3725   DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
3726
3727   /* Initialize the information structure for the function.  */
3728   allocate_struct_function (gnu_elab_proc_decl, false);
3729   set_cfun (NULL);
3730
3731   current_function_decl = NULL_TREE;
3732
3733   start_stmt_group ();
3734   gnat_pushlevel ();
3735
3736   /* For a body, first process the spec if there is one.  */
3737   if (Nkind (Unit (gnat_node)) == N_Package_Body
3738       || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3739               && !Acts_As_Spec (gnat_node)))
3740     {
3741       add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
3742       finalize_from_with_types ();
3743     }
3744
3745   /* If we can inline, generate code for all the inlined subprograms.  */
3746   if (optimize)
3747     {
3748       Entity_Id gnat_entity;
3749
3750       for (gnat_entity = First_Inlined_Subprogram (gnat_node);
3751            Present (gnat_entity);
3752            gnat_entity = Next_Inlined_Subprogram (gnat_entity))
3753         {
3754           Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
3755
3756           if (Nkind (gnat_body) != N_Subprogram_Body)
3757             {
3758               /* ??? This really should always be present.  */
3759               if (No (Corresponding_Body (gnat_body)))
3760                 continue;
3761               gnat_body
3762                 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
3763             }
3764
3765           if (Present (gnat_body))
3766             {
3767               /* Define the entity first so we set DECL_EXTERNAL.  */
3768               gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
3769               add_stmt (gnat_to_gnu (gnat_body));
3770             }
3771         }
3772     }
3773
3774   if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3775     {
3776       elaborate_all_entities (gnat_node);
3777
3778       if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
3779           || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
3780           || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
3781         return;
3782     }
3783
3784   process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
3785                  true, true);
3786   add_stmt (gnat_to_gnu (Unit (gnat_node)));
3787
3788   /* Process any pragmas and actions following the unit.  */
3789   add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
3790   add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
3791   finalize_from_with_types ();
3792
3793   /* Save away what we've made so far and record this potential elaboration
3794      procedure.  */
3795   info = ggc_alloc_elab_info ();
3796   set_current_block_context (gnu_elab_proc_decl);
3797   gnat_poplevel ();
3798   DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
3799
3800   Sloc_to_locus
3801     (Sloc (gnat_unit),
3802      &DECL_STRUCT_FUNCTION (gnu_elab_proc_decl)->function_end_locus);
3803
3804   info->next = elab_info_list;
3805   info->elab_proc = gnu_elab_proc_decl;
3806   info->gnat_node = gnat_node;
3807   elab_info_list = info;
3808
3809   /* Generate elaboration code for this unit, if necessary, and say whether
3810      we did or not.  */
3811   VEC_pop (tree, gnu_elab_proc_stack);
3812
3813   /* Invalidate the global renaming pointers.  This is necessary because
3814      stabilization of the renamed entities may create SAVE_EXPRs which
3815      have been tied to a specific elaboration routine just above.  */
3816   invalidate_global_renaming_pointers ();
3817 }
3818 \f
3819 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
3820    as gigi is concerned.  This is used to avoid conversions on the LHS.  */
3821
3822 static bool
3823 unchecked_conversion_nop (Node_Id gnat_node)
3824 {
3825   Entity_Id from_type, to_type;
3826
3827   /* The conversion must be on the LHS of an assignment or an actual parameter
3828      of a call.  Otherwise, even if the conversion was essentially a no-op, it
3829      could de facto ensure type consistency and this should be preserved.  */
3830   if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement
3831         && Name (Parent (gnat_node)) == gnat_node)
3832       && !((Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
3833             || Nkind (Parent (gnat_node)) == N_Function_Call)
3834            && Name (Parent (gnat_node)) != gnat_node))
3835     return false;
3836
3837   from_type = Etype (Expression (gnat_node));
3838
3839   /* We're interested in artificial conversions generated by the front-end
3840      to make private types explicit, e.g. in Expand_Assign_Array.  */
3841   if (!Is_Private_Type (from_type))
3842     return false;
3843
3844   from_type = Underlying_Type (from_type);
3845   to_type = Etype (gnat_node);
3846
3847   /* The direct conversion to the underlying type is a no-op.  */
3848   if (to_type == from_type)
3849     return true;
3850
3851   /* For an array subtype, the conversion to the PAT is a no-op.  */
3852   if (Ekind (from_type) == E_Array_Subtype
3853       && to_type == Packed_Array_Type (from_type))
3854     return true;
3855
3856   /* For a record subtype, the conversion to the type is a no-op.  */
3857   if (Ekind (from_type) == E_Record_Subtype
3858       && to_type == Etype (from_type))
3859     return true;
3860
3861   return false;
3862 }
3863
3864 /* This function is the driver of the GNAT to GCC tree transformation process.
3865    It is the entry point of the tree transformer.  GNAT_NODE is the root of
3866    some GNAT tree.  Return the root of the corresponding GCC tree.  If this
3867    is an expression, return the GCC equivalent of the expression.  If this
3868    is a statement, return the statement or add it to the current statement
3869    group, in which case anything returned is to be interpreted as occurring
3870    after anything added.  */
3871
3872 tree
3873 gnat_to_gnu (Node_Id gnat_node)
3874 {
3875   const Node_Kind kind = Nkind (gnat_node);
3876   bool went_into_elab_proc = false;
3877   tree gnu_result = error_mark_node; /* Default to no value.  */
3878   tree gnu_result_type = void_type_node;
3879   tree gnu_expr, gnu_lhs, gnu_rhs;
3880   Node_Id gnat_temp;
3881
3882   /* Save node number for error message and set location information.  */
3883   error_gnat_node = gnat_node;
3884   Sloc_to_locus (Sloc (gnat_node), &input_location);
3885
3886   /* If this node is a statement and we are only annotating types, return an
3887      empty statement list.  */
3888   if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
3889     return alloc_stmt_list ();
3890
3891   /* If this node is a non-static subexpression and we are only annotating
3892      types, make this into a NULL_EXPR.  */
3893   if (type_annotate_only
3894       && IN (kind, N_Subexpr)
3895       && kind != N_Identifier
3896       && !Compile_Time_Known_Value (gnat_node))
3897     return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
3898                    build_call_raise (CE_Range_Check_Failed, gnat_node,
3899                                      N_Raise_Constraint_Error));
3900
3901   if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
3902        && kind != N_Null_Statement)
3903       || kind == N_Procedure_Call_Statement
3904       || kind == N_Label
3905       || kind == N_Implicit_Label_Declaration
3906       || kind == N_Handled_Sequence_Of_Statements
3907       || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
3908     {
3909       tree current_elab_proc = get_elaboration_procedure ();
3910
3911       /* If this is a statement and we are at top level, it must be part of
3912          the elaboration procedure, so mark us as being in that procedure.  */
3913       if (!current_function_decl)
3914         {
3915           current_function_decl = current_elab_proc;
3916           went_into_elab_proc = true;
3917         }
3918
3919       /* If we are in the elaboration procedure, check if we are violating a
3920          No_Elaboration_Code restriction by having a statement there.  Don't
3921          check for a possible No_Elaboration_Code restriction violation on
3922          N_Handled_Sequence_Of_Statements, as we want to signal an error on
3923          every nested real statement instead.  This also avoids triggering
3924          spurious errors on dummy (empty) sequences created by the front-end
3925          for package bodies in some cases.  */
3926       if (current_function_decl == current_elab_proc
3927           && kind != N_Handled_Sequence_Of_Statements)
3928         Check_Elaboration_Code_Allowed (gnat_node);
3929     }
3930
3931   switch (kind)
3932     {
3933       /********************************/
3934       /* Chapter 2: Lexical Elements  */
3935       /********************************/
3936
3937     case N_Identifier:
3938     case N_Expanded_Name:
3939     case N_Operator_Symbol:
3940     case N_Defining_Identifier:
3941       gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
3942       break;
3943
3944     case N_Integer_Literal:
3945       {
3946         tree gnu_type;
3947
3948         /* Get the type of the result, looking inside any padding and
3949            justified modular types.  Then get the value in that type.  */
3950         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3951
3952         if (TREE_CODE (gnu_type) == RECORD_TYPE
3953             && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
3954           gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3955
3956         gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
3957
3958         /* If the result overflows (meaning it doesn't fit in its base type),
3959            abort.  We would like to check that the value is within the range
3960            of the subtype, but that causes problems with subtypes whose usage
3961            will raise Constraint_Error and with biased representation, so
3962            we don't.  */
3963         gcc_assert (!TREE_OVERFLOW (gnu_result));
3964       }
3965       break;
3966
3967     case N_Character_Literal:
3968       /* If a Entity is present, it means that this was one of the
3969          literals in a user-defined character type.  In that case,
3970          just return the value in the CONST_DECL.  Otherwise, use the
3971          character code.  In that case, the base type should be an
3972          INTEGER_TYPE, but we won't bother checking for that.  */
3973       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3974       if (Present (Entity (gnat_node)))
3975         gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
3976       else
3977         gnu_result
3978           = build_int_cst_type
3979               (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
3980       break;
3981
3982     case N_Real_Literal:
3983       /* If this is of a fixed-point type, the value we want is the
3984          value of the corresponding integer.  */
3985       if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
3986         {
3987           gnu_result_type = get_unpadded_type (Etype (gnat_node));
3988           gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
3989                                   gnu_result_type);
3990           gcc_assert (!TREE_OVERFLOW (gnu_result));
3991         }
3992
3993       /* We should never see a Vax_Float type literal, since the front end
3994          is supposed to transform these using appropriate conversions.  */
3995       else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
3996         gcc_unreachable ();
3997
3998       else
3999         {
4000           Ureal ur_realval = Realval (gnat_node);
4001
4002           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4003
4004           /* If the real value is zero, so is the result.  Otherwise,
4005              convert it to a machine number if it isn't already.  That
4006              forces BASE to 0 or 2 and simplifies the rest of our logic.  */
4007           if (UR_Is_Zero (ur_realval))
4008             gnu_result = convert (gnu_result_type, integer_zero_node);
4009           else
4010             {
4011               if (!Is_Machine_Number (gnat_node))
4012                 ur_realval
4013                   = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
4014                              ur_realval, Round_Even, gnat_node);
4015
4016               gnu_result
4017                 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
4018
4019               /* If we have a base of zero, divide by the denominator.
4020                  Otherwise, the base must be 2 and we scale the value, which
4021                  we know can fit in the mantissa of the type (hence the use
4022                  of that type above).  */
4023               if (No (Rbase (ur_realval)))
4024                 gnu_result
4025                   = build_binary_op (RDIV_EXPR,
4026                                      get_base_type (gnu_result_type),
4027                                      gnu_result,
4028                                      UI_To_gnu (Denominator (ur_realval),
4029                                                 gnu_result_type));
4030               else
4031                 {
4032                   REAL_VALUE_TYPE tmp;
4033
4034                   gcc_assert (Rbase (ur_realval) == 2);
4035                   real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
4036                               - UI_To_Int (Denominator (ur_realval)));
4037                   gnu_result = build_real (gnu_result_type, tmp);
4038                 }
4039             }
4040
4041           /* Now see if we need to negate the result.  Do it this way to
4042              properly handle -0.  */
4043           if (UR_Is_Negative (Realval (gnat_node)))
4044             gnu_result
4045               = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
4046                                 gnu_result);
4047         }
4048
4049       break;
4050
4051     case N_String_Literal:
4052       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4053       if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
4054         {
4055           String_Id gnat_string = Strval (gnat_node);
4056           int length = String_Length (gnat_string);
4057           int i;
4058           char *string;
4059           if (length >= ALLOCA_THRESHOLD)
4060             string = XNEWVEC (char, length + 1);
4061           else
4062             string = (char *) alloca (length + 1);
4063
4064           /* Build the string with the characters in the literal.  Note
4065              that Ada strings are 1-origin.  */
4066           for (i = 0; i < length; i++)
4067             string[i] = Get_String_Char (gnat_string, i + 1);
4068
4069           /* Put a null at the end of the string in case it's in a context
4070              where GCC will want to treat it as a C string.  */
4071           string[i] = 0;
4072
4073           gnu_result = build_string (length, string);
4074
4075           /* Strings in GCC don't normally have types, but we want
4076              this to not be converted to the array type.  */
4077           TREE_TYPE (gnu_result) = gnu_result_type;
4078
4079           if (length >= ALLOCA_THRESHOLD)
4080             free (string);
4081         }
4082       else
4083         {
4084           /* Build a list consisting of each character, then make
4085              the aggregate.  */
4086           String_Id gnat_string = Strval (gnat_node);
4087           int length = String_Length (gnat_string);
4088           int i;
4089           tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
4090           VEC(constructor_elt,gc) *gnu_vec
4091             = VEC_alloc (constructor_elt, gc, length);
4092
4093           for (i = 0; i < length; i++)
4094             {
4095               tree t = build_int_cst (TREE_TYPE (gnu_result_type),
4096                                       Get_String_Char (gnat_string, i + 1));
4097
4098               CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
4099               gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
4100                                          0);
4101             }
4102
4103           gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
4104         }
4105       break;
4106
4107     case N_Pragma:
4108       gnu_result = Pragma_to_gnu (gnat_node);
4109       break;
4110
4111     /**************************************/
4112     /* Chapter 3: Declarations and Types  */
4113     /**************************************/
4114
4115     case N_Subtype_Declaration:
4116     case N_Full_Type_Declaration:
4117     case N_Incomplete_Type_Declaration:
4118     case N_Private_Type_Declaration:
4119     case N_Private_Extension_Declaration:
4120     case N_Task_Type_Declaration:
4121       process_type (Defining_Entity (gnat_node));
4122       gnu_result = alloc_stmt_list ();
4123       break;
4124
4125     case N_Object_Declaration:
4126     case N_Exception_Declaration:
4127       gnat_temp = Defining_Entity (gnat_node);
4128       gnu_result = alloc_stmt_list ();
4129
4130       /* If we are just annotating types and this object has an unconstrained
4131          or task type, don't elaborate it.   */
4132       if (type_annotate_only
4133           && (((Is_Array_Type (Etype (gnat_temp))
4134                 || Is_Record_Type (Etype (gnat_temp)))
4135                && !Is_Constrained (Etype (gnat_temp)))
4136             || Is_Concurrent_Type (Etype (gnat_temp))))
4137         break;
4138
4139       if (Present (Expression (gnat_node))
4140           && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
4141           && (!type_annotate_only
4142               || Compile_Time_Known_Value (Expression (gnat_node))))
4143         {
4144           gnu_expr = gnat_to_gnu (Expression (gnat_node));
4145           if (Do_Range_Check (Expression (gnat_node)))
4146             gnu_expr
4147               = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
4148
4149           /* If this object has its elaboration delayed, we must force
4150              evaluation of GNU_EXPR right now and save it for when the object
4151              is frozen.  */
4152           if (Present (Freeze_Node (gnat_temp)))
4153             {
4154               if (TREE_CONSTANT (gnu_expr))
4155                 ;
4156               else if (global_bindings_p ())
4157                 gnu_expr
4158                   = create_var_decl (create_concat_name (gnat_temp, "init"),
4159                                      NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
4160                                      false, false, false, false,
4161                                      NULL, gnat_temp);
4162               else
4163                 gnu_expr = gnat_save_expr (gnu_expr);
4164
4165               save_gnu_tree (gnat_node, gnu_expr, true);
4166             }
4167         }
4168       else
4169         gnu_expr = NULL_TREE;
4170
4171       if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
4172         gnu_expr = NULL_TREE;
4173
4174       /* If this is a deferred constant with an address clause, we ignore the
4175          full view since the clause is on the partial view and we cannot have
4176          2 different GCC trees for the object.  The only bits of the full view
4177          we will use is the initializer, but it will be directly fetched.  */
4178       if (Ekind(gnat_temp) == E_Constant
4179           && Present (Address_Clause (gnat_temp))
4180           && Present (Full_View (gnat_temp)))
4181         save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
4182
4183       if (No (Freeze_Node (gnat_temp)))
4184         gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
4185       break;
4186
4187     case N_Object_Renaming_Declaration:
4188       gnat_temp = Defining_Entity (gnat_node);
4189
4190       /* Don't do anything if this renaming is handled by the front end or if
4191          we are just annotating types and this object has a composite or task
4192          type, don't elaborate it.  We return the result in case it has any
4193          SAVE_EXPRs in it that need to be evaluated here.  */
4194       if (!Is_Renaming_Of_Object (gnat_temp)
4195           && ! (type_annotate_only
4196                 && (Is_Array_Type (Etype (gnat_temp))
4197                     || Is_Record_Type (Etype (gnat_temp))
4198                     || Is_Concurrent_Type (Etype (gnat_temp)))))
4199         gnu_result
4200           = gnat_to_gnu_entity (gnat_temp,
4201                                 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
4202       else
4203         gnu_result = alloc_stmt_list ();
4204       break;
4205
4206     case N_Implicit_Label_Declaration:
4207       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
4208       gnu_result = alloc_stmt_list ();
4209       break;
4210
4211     case N_Exception_Renaming_Declaration:
4212     case N_Number_Declaration:
4213     case N_Package_Renaming_Declaration:
4214     case N_Subprogram_Renaming_Declaration:
4215       /* These are fully handled in the front end.  */
4216       gnu_result = alloc_stmt_list ();
4217       break;
4218
4219     /*************************************/
4220     /* Chapter 4: Names and Expressions  */
4221     /*************************************/
4222
4223     case N_Explicit_Dereference:
4224       gnu_result = gnat_to_gnu (Prefix (gnat_node));
4225       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4226       gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
4227       break;
4228
4229     case N_Indexed_Component:
4230       {
4231         tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
4232         tree gnu_type;
4233         int ndim;
4234         int i;
4235         Node_Id *gnat_expr_array;
4236
4237         gnu_array_object = maybe_implicit_deref (gnu_array_object);
4238
4239         /* Convert vector inputs to their representative array type, to fit
4240            what the code below expects.  */
4241         gnu_array_object = maybe_vector_array (gnu_array_object);
4242
4243         gnu_array_object = maybe_unconstrained_array (gnu_array_object);
4244
4245         /* If we got a padded type, remove it too.  */
4246         if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
4247           gnu_array_object
4248             = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
4249                        gnu_array_object);
4250
4251         gnu_result = gnu_array_object;
4252
4253         /* First compute the number of dimensions of the array, then
4254            fill the expression array, the order depending on whether
4255            this is a Convention_Fortran array or not.  */
4256         for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
4257              TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
4258              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
4259              ndim++, gnu_type = TREE_TYPE (gnu_type))
4260           ;
4261
4262         gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
4263
4264         if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
4265           for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
4266                i >= 0;
4267                i--, gnat_temp = Next (gnat_temp))
4268             gnat_expr_array[i] = gnat_temp;
4269         else
4270           for (i = 0, gnat_temp = First (Expressions (gnat_node));
4271                i < ndim;
4272                i++, gnat_temp = Next (gnat_temp))
4273             gnat_expr_array[i] = gnat_temp;
4274
4275         for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
4276              i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
4277           {
4278             gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
4279             gnat_temp = gnat_expr_array[i];
4280             gnu_expr = gnat_to_gnu (gnat_temp);
4281
4282             if (Do_Range_Check (gnat_temp))
4283               gnu_expr
4284                 = emit_index_check
4285                   (gnu_array_object, gnu_expr,
4286                    TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
4287                    TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
4288                    gnat_temp);
4289
4290             gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
4291                                           gnu_result, gnu_expr);
4292           }
4293       }
4294
4295       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4296       break;
4297
4298     case N_Slice:
4299       {
4300         Node_Id gnat_range_node = Discrete_Range (gnat_node);
4301         tree gnu_type;
4302
4303         gnu_result = gnat_to_gnu (Prefix (gnat_node));
4304         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4305
4306         /* Do any implicit dereferences of the prefix and do any needed
4307            range check.  */
4308         gnu_result = maybe_implicit_deref (gnu_result);
4309         gnu_result = maybe_unconstrained_array (gnu_result);
4310         gnu_type = TREE_TYPE (gnu_result);
4311         if (Do_Range_Check (gnat_range_node))
4312           {
4313             /* Get the bounds of the slice.  */
4314             tree gnu_index_type
4315               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
4316             tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
4317             tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
4318             /* Get the permitted bounds.  */
4319             tree gnu_base_index_type
4320               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
4321             tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
4322               (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
4323             tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
4324               (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
4325             tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
4326
4327            gnu_min_expr = gnat_protect_expr (gnu_min_expr);
4328            gnu_max_expr = gnat_protect_expr (gnu_max_expr);
4329
4330             /* Derive a good type to convert everything to.  */
4331             gnu_expr_type = get_base_type (gnu_index_type);
4332
4333             /* Test whether the minimum slice value is too small.  */
4334             gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
4335                                           convert (gnu_expr_type,
4336                                                    gnu_min_expr),
4337                                           convert (gnu_expr_type,
4338                                                    gnu_base_min_expr));
4339
4340             /* Test whether the maximum slice value is too large.  */
4341             gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
4342                                           convert (gnu_expr_type,
4343                                                    gnu_max_expr),
4344                                           convert (gnu_expr_type,
4345                                                    gnu_base_max_expr));
4346
4347             /* Build a slice index check that returns the low bound,
4348                assuming the slice is not empty.  */
4349             gnu_expr = emit_check
4350               (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
4351                                 gnu_expr_l, gnu_expr_h),
4352                gnu_min_expr, CE_Index_Check_Failed, gnat_node);
4353
4354            /* Build a conditional expression that does the index checks and
4355               returns the low bound if the slice is not empty (max >= min),
4356               and returns the naked low bound otherwise (max < min), unless
4357               it is non-constant and the high bound is; this prevents VRP
4358               from inferring bogus ranges on the unlikely path.  */
4359             gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
4360                                     build_binary_op (GE_EXPR, gnu_expr_type,
4361                                                      convert (gnu_expr_type,
4362                                                               gnu_max_expr),
4363                                                      convert (gnu_expr_type,
4364                                                               gnu_min_expr)),
4365                                     gnu_expr,
4366                                     TREE_CODE (gnu_min_expr) != INTEGER_CST
4367                                     && TREE_CODE (gnu_max_expr) == INTEGER_CST
4368                                     ? gnu_max_expr : gnu_min_expr);
4369           }
4370         else
4371           /* Simply return the naked low bound.  */
4372           gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
4373
4374         /* If this is a slice with non-constant size of an array with constant
4375            size, set the maximum size for the allocation of temporaries.  */
4376         if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
4377             && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
4378           TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
4379
4380         gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
4381                                       gnu_result, gnu_expr);
4382       }
4383       break;
4384
4385     case N_Selected_Component:
4386       {
4387         tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
4388         Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
4389         Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
4390         tree gnu_field;
4391
4392         while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
4393                || IN (Ekind (gnat_pref_type), Access_Kind))
4394           {
4395             if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
4396               gnat_pref_type = Underlying_Type (gnat_pref_type);
4397             else if (IN (Ekind (gnat_pref_type), Access_Kind))
4398               gnat_pref_type = Designated_Type (gnat_pref_type);
4399           }
4400
4401         gnu_prefix = maybe_implicit_deref (gnu_prefix);
4402
4403         /* For discriminant references in tagged types always substitute the
4404            corresponding discriminant as the actual selected component.  */
4405         if (Is_Tagged_Type (gnat_pref_type))
4406           while (Present (Corresponding_Discriminant (gnat_field)))
4407             gnat_field = Corresponding_Discriminant (gnat_field);
4408
4409         /* For discriminant references of untagged types always substitute the
4410            corresponding stored discriminant.  */
4411         else if (Present (Corresponding_Discriminant (gnat_field)))
4412           gnat_field = Original_Record_Component (gnat_field);
4413
4414         /* Handle extracting the real or imaginary part of a complex.
4415            The real part is the first field and the imaginary the last.  */
4416         if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
4417           gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
4418                                        ? REALPART_EXPR : IMAGPART_EXPR,
4419                                        NULL_TREE, gnu_prefix);
4420         else
4421           {
4422             gnu_field = gnat_to_gnu_field_decl (gnat_field);
4423
4424             /* If there are discriminants, the prefix might be evaluated more
4425                than once, which is a problem if it has side-effects.  */
4426             if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
4427                                    ? Designated_Type (Etype
4428                                                       (Prefix (gnat_node)))
4429                                    : Etype (Prefix (gnat_node))))
4430               gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL);
4431
4432             gnu_result
4433               = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
4434                                      (Nkind (Parent (gnat_node))
4435                                       == N_Attribute_Reference)
4436                                      && lvalue_required_for_attribute_p
4437                                         (Parent (gnat_node)));
4438           }
4439
4440         gcc_assert (gnu_result);
4441         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4442       }
4443       break;
4444
4445     case N_Attribute_Reference:
4446       {
4447         /* The attribute designator.  */
4448         const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
4449
4450         /* The Elab_Spec and Elab_Body attributes are special in that Prefix
4451            is a unit, not an object with a GCC equivalent.  */
4452         if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
4453           return
4454             create_subprog_decl (create_concat_name
4455                                  (Entity (Prefix (gnat_node)),
4456                                   attr == Attr_Elab_Body ? "elabb" : "elabs"),
4457                                  NULL_TREE, void_ftype, NULL_TREE, false,
4458                                  true, true, NULL, gnat_node);
4459
4460         gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
4461       }
4462       break;
4463
4464     case N_Reference:
4465       /* Like 'Access as far as we are concerned.  */
4466       gnu_result = gnat_to_gnu (Prefix (gnat_node));
4467       gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
4468       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4469       break;
4470
4471     case N_Aggregate:
4472     case N_Extension_Aggregate:
4473       {
4474         tree gnu_aggr_type;
4475
4476         /* ??? It is wrong to evaluate the type now, but there doesn't
4477            seem to be any other practical way of doing it.  */
4478
4479         gcc_assert (!Expansion_Delayed (gnat_node));
4480
4481         gnu_aggr_type = gnu_result_type
4482           = get_unpadded_type (Etype (gnat_node));
4483
4484         if (TREE_CODE (gnu_result_type) == RECORD_TYPE
4485             && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
4486           gnu_aggr_type
4487             = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
4488         else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
4489           gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
4490
4491         if (Null_Record_Present (gnat_node))
4492           gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
4493
4494         else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
4495                  || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
4496           gnu_result
4497             = assoc_to_constructor (Etype (gnat_node),
4498                                     First (Component_Associations (gnat_node)),
4499                                     gnu_aggr_type);
4500         else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
4501           gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
4502                                            gnu_aggr_type,
4503                                            Component_Type (Etype (gnat_node)));
4504         else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
4505           gnu_result
4506             = build_binary_op
4507               (COMPLEX_EXPR, gnu_aggr_type,
4508                gnat_to_gnu (Expression (First
4509                                         (Component_Associations (gnat_node)))),
4510                gnat_to_gnu (Expression
4511                             (Next
4512                              (First (Component_Associations (gnat_node))))));
4513         else
4514           gcc_unreachable ();
4515
4516         gnu_result = convert (gnu_result_type, gnu_result);
4517       }
4518       break;
4519
4520     case N_Null:
4521       if (TARGET_VTABLE_USES_DESCRIPTORS
4522           && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
4523           && Is_Dispatch_Table_Entity (Etype (gnat_node)))
4524         gnu_result = null_fdesc_node;
4525       else
4526         gnu_result = null_pointer_node;
4527       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4528       break;
4529
4530     case N_Type_Conversion:
4531     case N_Qualified_Expression:
4532       /* Get the operand expression.  */
4533       gnu_result = gnat_to_gnu (Expression (gnat_node));
4534       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4535
4536       gnu_result
4537         = convert_with_check (Etype (gnat_node), gnu_result,
4538                               Do_Overflow_Check (gnat_node),
4539                               Do_Range_Check (Expression (gnat_node)),
4540                               kind == N_Type_Conversion
4541                               && Float_Truncate (gnat_node), gnat_node);
4542       break;
4543
4544     case N_Unchecked_Type_Conversion:
4545       gnu_result = gnat_to_gnu (Expression (gnat_node));
4546
4547       /* Skip further processing if the conversion is deemed a no-op.  */
4548       if (unchecked_conversion_nop (gnat_node))
4549         {
4550           gnu_result_type = TREE_TYPE (gnu_result);
4551           break;
4552         }
4553
4554       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4555
4556       /* If the result is a pointer type, see if we are improperly
4557          converting to a stricter alignment.  */
4558       if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
4559           && IN (Ekind (Etype (gnat_node)), Access_Kind))
4560         {
4561           unsigned int align = known_alignment (gnu_result);
4562           tree gnu_obj_type = TREE_TYPE (gnu_result_type);
4563           unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
4564
4565           if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
4566             post_error_ne_tree_2
4567               ("?source alignment (^) '< alignment of & (^)",
4568                gnat_node, Designated_Type (Etype (gnat_node)),
4569                size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
4570         }
4571
4572       /* If we are converting a descriptor to a function pointer, first
4573          build the pointer.  */
4574       if (TARGET_VTABLE_USES_DESCRIPTORS
4575           && TREE_TYPE (gnu_result) == fdesc_type_node
4576           && POINTER_TYPE_P (gnu_result_type))
4577         gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
4578
4579       gnu_result = unchecked_convert (gnu_result_type, gnu_result,
4580                                       No_Truncation (gnat_node));
4581       break;
4582
4583     case N_In:
4584     case N_Not_In:
4585       {
4586         tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
4587         Node_Id gnat_range = Right_Opnd (gnat_node);
4588         tree gnu_low, gnu_high;
4589
4590         /* GNAT_RANGE is either an N_Range node or an identifier denoting a
4591            subtype.  */
4592         if (Nkind (gnat_range) == N_Range)
4593           {
4594             gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
4595             gnu_high = gnat_to_gnu (High_Bound (gnat_range));
4596           }
4597         else if (Nkind (gnat_range) == N_Identifier
4598                  || Nkind (gnat_range) == N_Expanded_Name)
4599           {
4600             tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
4601
4602             gnu_low = TYPE_MIN_VALUE (gnu_range_type);
4603             gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4604           }
4605         else
4606           gcc_unreachable ();
4607
4608         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4609
4610         /* If LOW and HIGH are identical, perform an equality test.  Otherwise,
4611            ensure that GNU_OBJ is evaluated only once and perform a full range
4612            test.  */
4613         if (operand_equal_p (gnu_low, gnu_high, 0))
4614           gnu_result
4615             = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
4616         else
4617           {
4618             tree t1, t2;
4619             gnu_obj = gnat_protect_expr (gnu_obj);
4620             t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
4621             if (EXPR_P (t1))
4622               set_expr_location_from_node (t1, gnat_node);
4623             t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
4624             if (EXPR_P (t2))
4625               set_expr_location_from_node (t2, gnat_node);
4626             gnu_result
4627               = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
4628           }
4629
4630         if (kind == N_Not_In)
4631           gnu_result
4632             = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
4633       }
4634       break;
4635
4636     case N_Op_Divide:
4637       gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4638       gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4639       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4640       gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
4641                                     ? RDIV_EXPR
4642                                     : (Rounded_Result (gnat_node)
4643                                        ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
4644                                     gnu_result_type, gnu_lhs, gnu_rhs);
4645       break;
4646
4647     case N_Op_Or:    case N_Op_And:      case N_Op_Xor:
4648       /* These can either be operations on booleans or on modular types.
4649          Fall through for boolean types since that's the way GNU_CODES is
4650          set up.  */
4651       if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
4652               Modular_Integer_Kind))
4653         {
4654           enum tree_code code
4655             = (kind == N_Op_Or ? BIT_IOR_EXPR
4656                : kind == N_Op_And ? BIT_AND_EXPR
4657                : BIT_XOR_EXPR);
4658
4659           gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4660           gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4661           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4662           gnu_result = build_binary_op (code, gnu_result_type,
4663                                         gnu_lhs, gnu_rhs);
4664           break;
4665         }
4666
4667       /* ... fall through ... */
4668
4669     case N_Op_Eq:    case N_Op_Ne:       case N_Op_Lt:
4670     case N_Op_Le:    case N_Op_Gt:       case N_Op_Ge:
4671     case N_Op_Add:   case N_Op_Subtract: case N_Op_Multiply:
4672     case N_Op_Mod:   case N_Op_Rem:
4673     case N_Op_Rotate_Left:
4674     case N_Op_Rotate_Right:
4675     case N_Op_Shift_Left:
4676     case N_Op_Shift_Right:
4677     case N_Op_Shift_Right_Arithmetic:
4678     case N_And_Then: case N_Or_Else:
4679       {
4680         enum tree_code code = gnu_codes[kind];
4681         bool ignore_lhs_overflow = false;
4682         location_t saved_location = input_location;
4683         tree gnu_type;
4684
4685         gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4686         gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4687         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
4688
4689         /* Pending generic support for efficient vector logical operations in
4690            GCC, convert vectors to their representative array type view and
4691            fallthrough.  */
4692         gnu_lhs = maybe_vector_array (gnu_lhs);
4693         gnu_rhs = maybe_vector_array (gnu_rhs);
4694
4695         /* If this is a comparison operator, convert any references to
4696            an unconstrained array value into a reference to the
4697            actual array.  */
4698         if (TREE_CODE_CLASS (code) == tcc_comparison)
4699           {
4700             gnu_lhs = maybe_unconstrained_array (gnu_lhs);
4701             gnu_rhs = maybe_unconstrained_array (gnu_rhs);
4702           }
4703
4704         /* If the result type is a private type, its full view may be a
4705            numeric subtype. The representation we need is that of its base
4706            type, given that it is the result of an arithmetic operation.  */
4707         else if (Is_Private_Type (Etype (gnat_node)))
4708           gnu_type = gnu_result_type
4709             = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
4710
4711         /* If this is a shift whose count is not guaranteed to be correct,
4712            we need to adjust the shift count.  */
4713         if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
4714           {
4715             tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
4716             tree gnu_max_shift
4717               = convert (gnu_count_type, TYPE_SIZE (gnu_type));
4718
4719             if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
4720               gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
4721                                          gnu_rhs, gnu_max_shift);
4722             else if (kind == N_Op_Shift_Right_Arithmetic)
4723               gnu_rhs
4724                 = build_binary_op
4725                   (MIN_EXPR, gnu_count_type,
4726                    build_binary_op (MINUS_EXPR,
4727                                     gnu_count_type,
4728                                     gnu_max_shift,
4729                                     convert (gnu_count_type,
4730                                              integer_one_node)),
4731                    gnu_rhs);
4732           }
4733
4734         /* For right shifts, the type says what kind of shift to do,
4735            so we may need to choose a different type.  In this case,
4736            we have to ignore integer overflow lest it propagates all
4737            the way down and causes a CE to be explicitly raised.  */
4738         if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
4739           {
4740             gnu_type = gnat_unsigned_type (gnu_type);
4741             ignore_lhs_overflow = true;
4742           }
4743         else if (kind == N_Op_Shift_Right_Arithmetic
4744                  && TYPE_UNSIGNED (gnu_type))
4745           {
4746             gnu_type = gnat_signed_type (gnu_type);
4747             ignore_lhs_overflow = true;
4748           }
4749
4750         if (gnu_type != gnu_result_type)
4751           {
4752             tree gnu_old_lhs = gnu_lhs;
4753             gnu_lhs = convert (gnu_type, gnu_lhs);
4754             if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
4755               TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
4756             gnu_rhs = convert (gnu_type, gnu_rhs);
4757           }
4758
4759         /* Instead of expanding overflow checks for addition, subtraction
4760            and multiplication itself, the front end will leave this to
4761            the back end when Backend_Overflow_Checks_On_Target is set.
4762            As the GCC back end itself does not know yet how to properly
4763            do overflow checking, do it here.  The goal is to push
4764            the expansions further into the back end over time.  */
4765         if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
4766             && (kind == N_Op_Add
4767                 || kind == N_Op_Subtract
4768                 || kind == N_Op_Multiply)
4769             && !TYPE_UNSIGNED (gnu_type)
4770             && !FLOAT_TYPE_P (gnu_type))
4771           gnu_result = build_binary_op_trapv (code, gnu_type,
4772                                               gnu_lhs, gnu_rhs, gnat_node);
4773         else
4774           {
4775             /* Some operations, e.g. comparisons of arrays, generate complex
4776                trees that need to be annotated while they are being built.  */
4777             input_location = saved_location;
4778             gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
4779           }
4780
4781         /* If this is a logical shift with the shift count not verified,
4782            we must return zero if it is too large.  We cannot compensate
4783            above in this case.  */
4784         if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
4785             && !Shift_Count_OK (gnat_node))
4786           gnu_result
4787             = build_cond_expr
4788               (gnu_type,
4789                build_binary_op (GE_EXPR, boolean_type_node,
4790                                 gnu_rhs,
4791                                 convert (TREE_TYPE (gnu_rhs),
4792                                          TYPE_SIZE (gnu_type))),
4793                convert (gnu_type, integer_zero_node),
4794                gnu_result);
4795       }
4796       break;
4797
4798     case N_Conditional_Expression:
4799       {
4800         tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
4801         tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
4802         tree gnu_false
4803           = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
4804
4805         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4806         gnu_result
4807           = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
4808       }
4809       break;
4810
4811     case N_Op_Plus:
4812       gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
4813       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4814       break;
4815
4816     case N_Op_Not:
4817       /* This case can apply to a boolean or a modular type.
4818          Fall through for a boolean operand since GNU_CODES is set
4819          up to handle this.  */
4820       if (Is_Modular_Integer_Type (Etype (gnat_node))
4821           || (Ekind (Etype (gnat_node)) == E_Private_Type
4822               && Is_Modular_Integer_Type (Full_View (Etype (gnat_node)))))
4823         {
4824           gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
4825           gnu_result_type = get_unpadded_type (Etype (gnat_node));
4826           gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
4827                                        gnu_expr);
4828           break;
4829         }
4830
4831       /* ... fall through ... */
4832
4833     case N_Op_Minus:  case N_Op_Abs:
4834       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
4835
4836       if (Ekind (Etype (gnat_node)) != E_Private_Type)
4837         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4838       else
4839         gnu_result_type = get_unpadded_type (Base_Type
4840                                              (Full_View (Etype (gnat_node))));
4841
4842       if (Do_Overflow_Check (gnat_node)
4843           && !TYPE_UNSIGNED (gnu_result_type)
4844           && !FLOAT_TYPE_P (gnu_result_type))
4845         gnu_result
4846           = build_unary_op_trapv (gnu_codes[kind],
4847                                   gnu_result_type, gnu_expr, gnat_node);
4848       else
4849         gnu_result = build_unary_op (gnu_codes[kind],
4850                                      gnu_result_type, gnu_expr);
4851       break;
4852
4853     case N_Allocator:
4854       {
4855         tree gnu_init = 0;
4856         tree gnu_type;
4857         bool ignore_init_type = false;
4858
4859         gnat_temp = Expression (gnat_node);
4860
4861         /* The Expression operand can either be an N_Identifier or
4862            Expanded_Name, which must represent a type, or a
4863            N_Qualified_Expression, which contains both the object type and an
4864            initial value for the object.  */
4865         if (Nkind (gnat_temp) == N_Identifier
4866             || Nkind (gnat_temp) == N_Expanded_Name)
4867           gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
4868         else if (Nkind (gnat_temp) == N_Qualified_Expression)
4869           {
4870             Entity_Id gnat_desig_type
4871               = Designated_Type (Underlying_Type (Etype (gnat_node)));
4872
4873             ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
4874             gnu_init = gnat_to_gnu (Expression (gnat_temp));
4875
4876             gnu_init = maybe_unconstrained_array (gnu_init);
4877             if (Do_Range_Check (Expression (gnat_temp)))
4878               gnu_init
4879                 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
4880
4881             if (Is_Elementary_Type (gnat_desig_type)
4882                 || Is_Constrained (gnat_desig_type))
4883               {
4884                 gnu_type = gnat_to_gnu_type (gnat_desig_type);
4885                 gnu_init = convert (gnu_type, gnu_init);
4886               }
4887             else
4888               {
4889                 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
4890                 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4891                   gnu_type = TREE_TYPE (gnu_init);
4892
4893                 gnu_init = convert (gnu_type, gnu_init);
4894               }
4895           }
4896         else
4897           gcc_unreachable ();
4898
4899         gnu_result_type = get_unpadded_type (Etype (gnat_node));
4900         return build_allocator (gnu_type, gnu_init, gnu_result_type,
4901                                 Procedure_To_Call (gnat_node),
4902                                 Storage_Pool (gnat_node), gnat_node,
4903                                 ignore_init_type);
4904       }
4905       break;
4906
4907     /**************************/
4908     /* Chapter 5: Statements  */
4909     /**************************/
4910
4911     case N_Label:
4912       gnu_result = build1 (LABEL_EXPR, void_type_node,
4913                            gnat_to_gnu (Identifier (gnat_node)));
4914       break;
4915
4916     case N_Null_Statement:
4917       /* When not optimizing, turn null statements from source into gotos to
4918          the next statement that the middle-end knows how to preserve.  */
4919       if (!optimize && Comes_From_Source (gnat_node))
4920         {
4921           tree stmt, label = create_label_decl (NULL_TREE);
4922           start_stmt_group ();
4923           stmt = build1 (GOTO_EXPR, void_type_node, label);
4924           set_expr_location_from_node (stmt, gnat_node);
4925           add_stmt (stmt);
4926           stmt = build1 (LABEL_EXPR, void_type_node, label);
4927           set_expr_location_from_node (stmt, gnat_node);
4928           add_stmt (stmt);
4929           gnu_result = end_stmt_group ();
4930         }
4931       else
4932         gnu_result = alloc_stmt_list ();
4933       break;
4934
4935     case N_Assignment_Statement:
4936       /* Get the LHS and RHS of the statement and convert any reference to an
4937          unconstrained array into a reference to the underlying array.  */
4938       gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
4939
4940       /* If the type has a size that overflows, convert this into raise of
4941          Storage_Error: execution shouldn't have gotten here anyway.  */
4942       if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
4943            && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
4944         gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
4945                                        N_Raise_Storage_Error);
4946       else if (Nkind (Expression (gnat_node)) == N_Function_Call)
4947         gnu_result
4948           = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs);
4949       else
4950         {
4951           gnu_rhs
4952             = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
4953
4954           /* If range check is needed, emit code to generate it.  */
4955           if (Do_Range_Check (Expression (gnat_node)))
4956             gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
4957                                         gnat_node);
4958
4959           gnu_result
4960             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
4961
4962           /* If the type being assigned is an array type and the two sides are
4963              not completely disjoint, play safe and use memmove.  But don't do
4964              it for a bit-packed array as it might not be byte-aligned.  */
4965           if (TREE_CODE (gnu_result) == MODIFY_EXPR
4966               && Is_Array_Type (Etype (Name (gnat_node)))
4967               && !Is_Bit_Packed_Array (Etype (Name (gnat_node)))
4968               && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
4969             {
4970               tree to, from, size, to_ptr, from_ptr, t;
4971
4972               to = TREE_OPERAND (gnu_result, 0);
4973               from = TREE_OPERAND (gnu_result, 1);
4974
4975               size = TYPE_SIZE_UNIT (TREE_TYPE (from));
4976               size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from);
4977
4978               to_ptr = build_fold_addr_expr (to);
4979               from_ptr = build_fold_addr_expr (from);
4980
4981               t = implicit_built_in_decls[BUILT_IN_MEMMOVE];
4982               gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
4983            }
4984         }
4985       break;
4986
4987     case N_If_Statement:
4988       {
4989         tree *gnu_else_ptr; /* Point to put next "else if" or "else".  */
4990
4991         /* Make the outer COND_EXPR.  Avoid non-determinism.  */
4992         gnu_result = build3 (COND_EXPR, void_type_node,
4993                              gnat_to_gnu (Condition (gnat_node)),
4994                              NULL_TREE, NULL_TREE);
4995         COND_EXPR_THEN (gnu_result)
4996           = build_stmt_group (Then_Statements (gnat_node), false);
4997         TREE_SIDE_EFFECTS (gnu_result) = 1;
4998         gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
4999
5000         /* Now make a COND_EXPR for each of the "else if" parts.  Put each
5001            into the previous "else" part and point to where to put any
5002            outer "else".  Also avoid non-determinism.  */
5003         if (Present (Elsif_Parts (gnat_node)))
5004           for (gnat_temp = First (Elsif_Parts (gnat_node));
5005                Present (gnat_temp); gnat_temp = Next (gnat_temp))
5006             {
5007               gnu_expr = build3 (COND_EXPR, void_type_node,
5008                                  gnat_to_gnu (Condition (gnat_temp)),
5009                                  NULL_TREE, NULL_TREE);
5010               COND_EXPR_THEN (gnu_expr)
5011                 = build_stmt_group (Then_Statements (gnat_temp), false);
5012               TREE_SIDE_EFFECTS (gnu_expr) = 1;
5013               set_expr_location_from_node (gnu_expr, gnat_temp);
5014               *gnu_else_ptr = gnu_expr;
5015               gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
5016             }
5017
5018         *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
5019       }
5020       break;
5021
5022     case N_Case_Statement:
5023       gnu_result = Case_Statement_to_gnu (gnat_node);
5024       break;
5025
5026     case N_Loop_Statement:
5027       gnu_result = Loop_Statement_to_gnu (gnat_node);
5028       break;
5029
5030     case N_Block_Statement:
5031       start_stmt_group ();
5032       gnat_pushlevel ();
5033       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
5034       add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
5035       gnat_poplevel ();
5036       gnu_result = end_stmt_group ();
5037
5038       if (Present (Identifier (gnat_node)))
5039         mark_out_of_scope (Entity (Identifier (gnat_node)));
5040       break;
5041
5042     case N_Exit_Statement:
5043       gnu_result
5044         = build2 (EXIT_STMT, void_type_node,
5045                   (Present (Condition (gnat_node))
5046                    ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
5047                   (Present (Name (gnat_node))
5048                    ? get_gnu_tree (Entity (Name (gnat_node)))
5049                    : VEC_last (tree, gnu_loop_label_stack)));
5050       break;
5051
5052     case N_Return_Statement:
5053       {
5054         tree gnu_ret_val, gnu_ret_obj;
5055
5056         /* If the subprogram is a function, we must return the expression.  */
5057         if (Present (Expression (gnat_node)))
5058           {
5059             tree gnu_subprog_type = TREE_TYPE (current_function_decl);
5060             tree gnu_ret_type = TREE_TYPE (gnu_subprog_type);
5061             tree gnu_result_decl = DECL_RESULT (current_function_decl);
5062             gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
5063
5064             /* If this function has copy-in/copy-out parameters, get the real
5065                variable and type for the return.  See Subprogram_to_gnu.  */
5066             if (TYPE_CI_CO_LIST (gnu_subprog_type))
5067               {
5068                 gnu_result_decl = VEC_last (tree, gnu_return_var_stack);
5069                 gnu_ret_type = TREE_TYPE (gnu_result_decl);
5070               }
5071
5072             /* Do not remove the padding from GNU_RET_VAL if the inner type is
5073                self-referential since we want to allocate the fixed size.  */
5074             if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
5075                 && TYPE_IS_PADDING_P
5076                    (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
5077                 && CONTAINS_PLACEHOLDER_P
5078                    (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
5079               gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
5080
5081             /* If the subprogram returns by direct reference, return a pointer
5082                to the return value.  */
5083             if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
5084                 || By_Ref (gnat_node))
5085               gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
5086
5087             /* Otherwise, if it returns an unconstrained array, we have to
5088                allocate a new version of the result and return it.  */
5089             else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
5090               {
5091                 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
5092                 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
5093                                                gnu_ret_val, gnu_ret_type,
5094                                                Procedure_To_Call (gnat_node),
5095                                                Storage_Pool (gnat_node),
5096                                                gnat_node, false);
5097               }
5098
5099             /* If the subprogram returns by invisible reference, dereference
5100                the pointer it is passed using the type of the return value
5101                and build the copy operation manually.  This ensures that we
5102                don't copy too much data, for example if the return type is
5103                unconstrained with a maximum size.  */
5104             if (TREE_ADDRESSABLE (gnu_subprog_type))
5105               {
5106                 gnu_ret_obj
5107                   = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
5108                                     gnu_result_decl);
5109                 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
5110                                               gnu_ret_obj, gnu_ret_val);
5111                 add_stmt_with_node (gnu_result, gnat_node);
5112                 gnu_ret_val = NULL_TREE;
5113                 gnu_ret_obj = gnu_result_decl;
5114               }
5115
5116             /* Otherwise, build a regular return.  */
5117             else
5118               gnu_ret_obj = gnu_result_decl;
5119           }
5120         else
5121           {
5122             gnu_ret_val = NULL_TREE;
5123             gnu_ret_obj = NULL_TREE;
5124           }
5125
5126         /* If we have a return label defined, convert this into a branch to
5127            that label.  The return proper will be handled elsewhere.  */
5128         if (VEC_last (tree, gnu_return_label_stack))
5129           {
5130             if (gnu_ret_obj)
5131               add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
5132                                          gnu_ret_val));
5133
5134             gnu_result = build1 (GOTO_EXPR, void_type_node,
5135                                  VEC_last (tree, gnu_return_label_stack));
5136             /* When not optimizing, make sure the return is preserved.  */
5137             if (!optimize && Comes_From_Source (gnat_node))
5138               DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0;
5139             break;
5140           }
5141
5142         gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
5143       }
5144       break;
5145
5146     case N_Goto_Statement:
5147       gnu_result = build1 (GOTO_EXPR, void_type_node,
5148                            gnat_to_gnu (Name (gnat_node)));
5149       break;
5150
5151     /***************************/
5152     /* Chapter 6: Subprograms  */
5153     /***************************/
5154
5155     case N_Subprogram_Declaration:
5156       /* Unless there is a freeze node, declare the subprogram.  We consider
5157          this a "definition" even though we're not generating code for
5158          the subprogram because we will be making the corresponding GCC
5159          node here.  */
5160
5161       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
5162         gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
5163                             NULL_TREE, 1);
5164       gnu_result = alloc_stmt_list ();
5165       break;
5166
5167     case N_Abstract_Subprogram_Declaration:
5168       /* This subprogram doesn't exist for code generation purposes, but we
5169          have to elaborate the types of any parameters and result, unless
5170          they are imported types (nothing to generate in this case).
5171
5172          The parameter list may contain types with freeze nodes, e.g. not null
5173          subtypes, so the subprogram itself may carry a freeze node, in which
5174          case its elaboration must be deferred.  */
5175
5176       /* Process the parameter types first.  */
5177       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
5178       for (gnat_temp
5179            = First_Formal_With_Extras
5180               (Defining_Entity (Specification (gnat_node)));
5181            Present (gnat_temp);
5182            gnat_temp = Next_Formal_With_Extras (gnat_temp))
5183         if (Is_Itype (Etype (gnat_temp))
5184             && !From_With_Type (Etype (gnat_temp)))
5185           gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
5186
5187       /* Then the result type, set to Standard_Void_Type for procedures.  */
5188       {
5189         Entity_Id gnat_temp_type
5190           = Etype (Defining_Entity (Specification (gnat_node)));
5191
5192         if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
5193           gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
5194       }
5195
5196       gnu_result = alloc_stmt_list ();
5197       break;
5198
5199     case N_Defining_Program_Unit_Name:
5200       /* For a child unit identifier go up a level to get the specification.
5201          We get this when we try to find the spec of a child unit package
5202          that is the compilation unit being compiled.  */
5203       gnu_result = gnat_to_gnu (Parent (gnat_node));
5204       break;
5205
5206     case N_Subprogram_Body:
5207       Subprogram_Body_to_gnu (gnat_node);
5208       gnu_result = alloc_stmt_list ();
5209       break;
5210
5211     case N_Function_Call:
5212     case N_Procedure_Call_Statement:
5213       gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
5214       break;
5215
5216     /************************/
5217     /* Chapter 7: Packages  */
5218     /************************/
5219
5220     case N_Package_Declaration:
5221       gnu_result = gnat_to_gnu (Specification (gnat_node));
5222       break;
5223
5224     case N_Package_Specification:
5225
5226       start_stmt_group ();
5227       process_decls (Visible_Declarations (gnat_node),
5228                      Private_Declarations (gnat_node), Empty, true, true);
5229       gnu_result = end_stmt_group ();
5230       break;
5231
5232     case N_Package_Body:
5233
5234       /* If this is the body of a generic package - do nothing.  */
5235       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
5236         {
5237           gnu_result = alloc_stmt_list ();
5238           break;
5239         }
5240
5241       start_stmt_group ();
5242       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
5243
5244       if (Present (Handled_Statement_Sequence (gnat_node)))
5245         add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
5246
5247       gnu_result = end_stmt_group ();
5248       break;
5249
5250     /********************************/
5251     /* Chapter 8: Visibility Rules  */
5252     /********************************/
5253
5254     case N_Use_Package_Clause:
5255     case N_Use_Type_Clause:
5256       /* Nothing to do here - but these may appear in list of declarations.  */
5257       gnu_result = alloc_stmt_list ();
5258       break;
5259
5260     /*********************/
5261     /* Chapter 9: Tasks  */
5262     /*********************/
5263
5264     case N_Protected_Type_Declaration:
5265       gnu_result = alloc_stmt_list ();
5266       break;
5267
5268     case N_Single_Task_Declaration:
5269       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
5270       gnu_result = alloc_stmt_list ();
5271       break;
5272
5273     /*********************************************************/
5274     /* Chapter 10: Program Structure and Compilation Issues  */
5275     /*********************************************************/
5276
5277     case N_Compilation_Unit:
5278       /* This is not called for the main unit on which gigi is invoked.  */
5279       Compilation_Unit_to_gnu (gnat_node);
5280       gnu_result = alloc_stmt_list ();
5281       break;
5282
5283     case N_Subprogram_Body_Stub:
5284     case N_Package_Body_Stub:
5285     case N_Protected_Body_Stub:
5286     case N_Task_Body_Stub:
5287       /* Simply process whatever unit is being inserted.  */
5288       gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
5289       break;
5290
5291     case N_Subunit:
5292       gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
5293       break;
5294
5295     /***************************/
5296     /* Chapter 11: Exceptions  */
5297     /***************************/
5298
5299     case N_Handled_Sequence_Of_Statements:
5300       /* If there is an At_End procedure attached to this node, and the EH
5301          mechanism is SJLJ, we must have at least a corresponding At_End
5302          handler, unless the No_Exception_Handlers restriction is set.  */
5303       gcc_assert (type_annotate_only
5304                   || Exception_Mechanism != Setjmp_Longjmp
5305                   || No (At_End_Proc (gnat_node))
5306                   || Present (Exception_Handlers (gnat_node))
5307                   || No_Exception_Handlers_Set ());
5308
5309       gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
5310       break;
5311
5312     case N_Exception_Handler:
5313       if (Exception_Mechanism == Setjmp_Longjmp)
5314         gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
5315       else if (Exception_Mechanism == Back_End_Exceptions)
5316         gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
5317       else
5318         gcc_unreachable ();
5319
5320       break;
5321
5322     case N_Push_Constraint_Error_Label:
5323       push_exception_label_stack (&gnu_constraint_error_label_stack,
5324                                   Exception_Label (gnat_node));
5325       break;
5326
5327     case N_Push_Storage_Error_Label:
5328       push_exception_label_stack (&gnu_storage_error_label_stack,
5329                                   Exception_Label (gnat_node));
5330       break;
5331
5332     case N_Push_Program_Error_Label:
5333       push_exception_label_stack (&gnu_program_error_label_stack,
5334                                   Exception_Label (gnat_node));
5335       break;
5336
5337     case N_Pop_Constraint_Error_Label:
5338       VEC_pop (tree, gnu_constraint_error_label_stack);
5339       break;
5340
5341     case N_Pop_Storage_Error_Label:
5342       VEC_pop (tree, gnu_storage_error_label_stack);
5343       break;
5344
5345     case N_Pop_Program_Error_Label:
5346       VEC_pop (tree, gnu_program_error_label_stack);
5347       break;
5348
5349     /******************************/
5350     /* Chapter 12: Generic Units  */
5351     /******************************/
5352
5353     case N_Generic_Function_Renaming_Declaration:
5354     case N_Generic_Package_Renaming_Declaration:
5355     case N_Generic_Procedure_Renaming_Declaration:
5356     case N_Generic_Package_Declaration:
5357     case N_Generic_Subprogram_Declaration:
5358     case N_Package_Instantiation:
5359     case N_Procedure_Instantiation:
5360     case N_Function_Instantiation:
5361       /* These nodes can appear on a declaration list but there is nothing to
5362          to be done with them.  */
5363       gnu_result = alloc_stmt_list ();
5364       break;
5365
5366     /**************************************************/
5367     /* Chapter 13: Representation Clauses and         */
5368     /*             Implementation-Dependent Features  */
5369     /**************************************************/
5370
5371     case N_Attribute_Definition_Clause:
5372       gnu_result = alloc_stmt_list ();
5373
5374       /* The only one we need to deal with is 'Address since, for the others,
5375          the front-end puts the information elsewhere.  */
5376       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
5377         break;
5378
5379       /* And we only deal with 'Address if the object has a Freeze node.  */
5380       gnat_temp = Entity (Name (gnat_node));
5381       if (No (Freeze_Node (gnat_temp)))
5382         break;
5383
5384       /* Get the value to use as the address and save it as the equivalent
5385          for the object.  When it is frozen, gnat_to_gnu_entity will do the
5386          right thing.  */
5387       save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
5388       break;
5389
5390     case N_Enumeration_Representation_Clause:
5391     case N_Record_Representation_Clause:
5392     case N_At_Clause:
5393       /* We do nothing with these.  SEM puts the information elsewhere.  */
5394       gnu_result = alloc_stmt_list ();
5395       break;
5396
5397     case N_Code_Statement:
5398       if (!type_annotate_only)
5399         {
5400           tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
5401           tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
5402           tree gnu_clobbers = NULL_TREE, tail;
5403           bool allows_mem, allows_reg, fake;
5404           int ninputs, noutputs, i;
5405           const char **oconstraints;
5406           const char *constraint;
5407           char *clobber;
5408
5409           /* First retrieve the 3 operand lists built by the front-end.  */
5410           Setup_Asm_Outputs (gnat_node);
5411           while (Present (gnat_temp = Asm_Output_Variable ()))
5412             {
5413               tree gnu_value = gnat_to_gnu (gnat_temp);
5414               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
5415                                                  (Asm_Output_Constraint ()));
5416
5417               gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
5418               Next_Asm_Output ();
5419             }
5420
5421           Setup_Asm_Inputs (gnat_node);
5422           while (Present (gnat_temp = Asm_Input_Value ()))
5423             {
5424               tree gnu_value = gnat_to_gnu (gnat_temp);
5425               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
5426                                                  (Asm_Input_Constraint ()));
5427
5428               gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
5429               Next_Asm_Input ();
5430             }
5431
5432           Clobber_Setup (gnat_node);
5433           while ((clobber = Clobber_Get_Next ()))
5434             gnu_clobbers
5435               = tree_cons (NULL_TREE,
5436                            build_string (strlen (clobber) + 1, clobber),
5437                            gnu_clobbers);
5438
5439           /* Then perform some standard checking and processing on the
5440              operands.  In particular, mark them addressable if needed.  */
5441           gnu_outputs = nreverse (gnu_outputs);
5442           noutputs = list_length (gnu_outputs);
5443           gnu_inputs = nreverse (gnu_inputs);
5444           ninputs = list_length (gnu_inputs);
5445           oconstraints = XALLOCAVEC (const char *, noutputs);
5446
5447           for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
5448             {
5449               tree output = TREE_VALUE (tail);
5450               constraint
5451                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
5452               oconstraints[i] = constraint;
5453
5454               if (parse_output_constraint (&constraint, i, ninputs, noutputs,
5455                                            &allows_mem, &allows_reg, &fake))
5456                 {
5457                   /* If the operand is going to end up in memory,
5458                      mark it addressable.  Note that we don't test
5459                      allows_mem like in the input case below; this
5460                      is modelled on the C front-end.  */
5461                   if (!allows_reg
5462                       && !gnat_mark_addressable (output))
5463                     output = error_mark_node;
5464                 }
5465               else
5466                 output = error_mark_node;
5467
5468               TREE_VALUE (tail) = output;
5469             }
5470
5471           for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
5472             {
5473               tree input = TREE_VALUE (tail);
5474               constraint
5475                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
5476
5477               if (parse_input_constraint (&constraint, i, ninputs, noutputs,
5478                                           0, oconstraints,
5479                                           &allows_mem, &allows_reg))
5480                 {
5481                   /* If the operand is going to end up in memory,
5482                      mark it addressable.  */
5483                   if (!allows_reg && allows_mem
5484                       && !gnat_mark_addressable (input))
5485                     input = error_mark_node;
5486                 }
5487               else
5488                 input = error_mark_node;
5489
5490               TREE_VALUE (tail) = input;
5491             }
5492
5493           gnu_result = build5 (ASM_EXPR,  void_type_node,
5494                                gnu_template, gnu_outputs,
5495                                gnu_inputs, gnu_clobbers, NULL_TREE);
5496           ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
5497         }
5498       else
5499         gnu_result = alloc_stmt_list ();
5500
5501       break;
5502
5503     /****************/
5504     /* Added Nodes  */
5505     /****************/
5506
5507     case N_Expression_With_Actions:
5508       gnu_result_type = get_unpadded_type (Etype (gnat_node));
5509       /* This construct doesn't define a scope so we don't wrap the statement
5510          list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it
5511          from unsharing.  */
5512       gnu_result = build_stmt_group (Actions (gnat_node), false);
5513       gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
5514       TREE_SIDE_EFFECTS (gnu_result) = 1;
5515       gnu_expr = gnat_to_gnu (Expression (gnat_node));
5516       gnu_result
5517         = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
5518       break;
5519
5520     case N_Freeze_Entity:
5521       start_stmt_group ();
5522       process_freeze_entity (gnat_node);
5523       process_decls (Actions (gnat_node), Empty, Empty, true, true);
5524       gnu_result = end_stmt_group ();
5525       break;
5526
5527     case N_Itype_Reference:
5528       if (!present_gnu_tree (Itype (gnat_node)))
5529         process_type (Itype (gnat_node));
5530
5531       gnu_result = alloc_stmt_list ();
5532       break;
5533
5534     case N_Free_Statement:
5535       if (!type_annotate_only)
5536         {
5537           tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
5538           tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
5539           tree gnu_obj_type;
5540           tree gnu_actual_obj_type = 0;
5541           tree gnu_obj_size;
5542
5543           /* If this is a thin pointer, we must dereference it to create
5544              a fat pointer, then go back below to a thin pointer.  The
5545              reason for this is that we need a fat pointer someplace in
5546              order to properly compute the size.  */
5547           if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
5548             gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
5549                                       build_unary_op (INDIRECT_REF, NULL_TREE,
5550                                                       gnu_ptr));
5551
5552           /* If this is an unconstrained array, we know the object must
5553              have been allocated with the template in front of the object.
5554              So pass the template address, but get the total size.  Do this
5555              by converting to a thin pointer.  */
5556           if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
5557             gnu_ptr
5558               = convert (build_pointer_type
5559                          (TYPE_OBJECT_RECORD_TYPE
5560                           (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
5561                          gnu_ptr);
5562
5563           gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
5564
5565           if (Present (Actual_Designated_Subtype (gnat_node)))
5566             {
5567               gnu_actual_obj_type
5568                 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
5569
5570               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
5571                 gnu_actual_obj_type
5572                   = build_unc_object_type_from_ptr (gnu_ptr_type,
5573                                                     gnu_actual_obj_type,
5574                                                     get_identifier ("DEALLOC"),
5575                                                     false);
5576             }
5577           else
5578             gnu_actual_obj_type = gnu_obj_type;
5579
5580           gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
5581
5582           if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
5583               && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
5584             {
5585               tree gnu_char_ptr_type
5586                 = build_pointer_type (unsigned_char_type_node);
5587               tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
5588               gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
5589               gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
5590                                          gnu_ptr, gnu_pos);
5591             }
5592
5593           gnu_result
5594               = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
5595                                           Procedure_To_Call (gnat_node),
5596                                           Storage_Pool (gnat_node),
5597                                           gnat_node);
5598         }
5599       break;
5600
5601     case N_Raise_Constraint_Error:
5602     case N_Raise_Program_Error:
5603     case N_Raise_Storage_Error:
5604       {
5605         const int reason = UI_To_Int (Reason (gnat_node));
5606         const Node_Id cond = Condition (gnat_node);
5607         bool handled = false;
5608
5609         if (type_annotate_only)
5610           {
5611             gnu_result = alloc_stmt_list ();
5612             break;
5613           }
5614
5615         gnu_result_type = get_unpadded_type (Etype (gnat_node));
5616
5617         if (Exception_Extra_Info
5618             && !No_Exception_Handlers_Set ()
5619             && !get_exception_label (kind)
5620             && TREE_CODE (gnu_result_type) == VOID_TYPE
5621             && Present (cond))
5622           {
5623             if (reason == CE_Access_Check_Failed)
5624               {
5625                 gnu_result = build_call_raise_column (reason, gnat_node);
5626                 handled = true;
5627               }
5628             else if ((reason == CE_Index_Check_Failed
5629                       || reason == CE_Range_Check_Failed
5630                       || reason == CE_Invalid_Data)
5631                      && Nkind (cond) == N_Op_Not
5632                      && Nkind (Right_Opnd (cond)) == N_In
5633                      && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range)
5634               {
5635                 Node_Id op = Right_Opnd (cond);  /* N_In node */
5636                 Node_Id index = Left_Opnd (op);
5637                 Node_Id type = Etype (index);
5638
5639                 if (Is_Type (type)
5640                     && Known_Esize (type)
5641                     && UI_To_Int (Esize (type)) <= 32)
5642                   {
5643                     Node_Id right_op = Right_Opnd (op);
5644                     gnu_result
5645                       = build_call_raise_range
5646                         (reason, gnat_node,
5647                          gnat_to_gnu (index),                  /* index */
5648                          gnat_to_gnu (Low_Bound (right_op)),   /* first */
5649                          gnat_to_gnu (High_Bound (right_op))); /* last  */
5650                     handled = true;
5651                   }
5652               }
5653           }
5654
5655         if (handled)
5656           {
5657             set_expr_location_from_node (gnu_result, gnat_node);
5658             gnu_result = build3 (COND_EXPR, void_type_node,
5659                                  gnat_to_gnu (cond),
5660                                  gnu_result, alloc_stmt_list ());
5661           }
5662         else
5663           {
5664             gnu_result = build_call_raise (reason, gnat_node, kind);
5665
5666             /* If the type is VOID, this is a statement, so we need to generate
5667                the code for the call.  Handle a Condition, if there is one.  */
5668             if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5669               {
5670                 set_expr_location_from_node (gnu_result, gnat_node);
5671                 if (Present (cond))
5672                   gnu_result = build3 (COND_EXPR, void_type_node,
5673                                        gnat_to_gnu (cond),
5674                                        gnu_result, alloc_stmt_list ());
5675               }
5676             else
5677               gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
5678           }
5679       }
5680       break;
5681
5682     case N_Validate_Unchecked_Conversion:
5683       {
5684         Entity_Id gnat_target_type = Target_Type (gnat_node);
5685         tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
5686         tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
5687
5688         /* No need for any warning in this case.  */
5689         if (!flag_strict_aliasing)
5690           ;
5691
5692         /* If the result is a pointer type, see if we are either converting
5693            from a non-pointer or from a pointer to a type with a different
5694            alias set and warn if so.  If the result is defined in the same
5695            unit as this unchecked conversion, we can allow this because we
5696            can know to make the pointer type behave properly.  */
5697         else if (POINTER_TYPE_P (gnu_target_type)
5698                  && !In_Same_Source_Unit (gnat_target_type, gnat_node)
5699                  && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
5700           {
5701             tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
5702                                          ? TREE_TYPE (gnu_source_type)
5703                                          : NULL_TREE;
5704             tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
5705
5706             if ((TYPE_DUMMY_P (gnu_target_desig_type)
5707                  || get_alias_set (gnu_target_desig_type) != 0)
5708                 && (!POINTER_TYPE_P (gnu_source_type)
5709                     || (TYPE_DUMMY_P (gnu_source_desig_type)
5710                         != TYPE_DUMMY_P (gnu_target_desig_type))
5711                     || (TYPE_DUMMY_P (gnu_source_desig_type)
5712                         && gnu_source_desig_type != gnu_target_desig_type)
5713                     || !alias_sets_conflict_p
5714                         (get_alias_set (gnu_source_desig_type),
5715                          get_alias_set (gnu_target_desig_type))))
5716               {
5717                 post_error_ne
5718                   ("?possible aliasing problem for type&",
5719                    gnat_node, Target_Type (gnat_node));
5720                 post_error
5721                   ("\\?use -fno-strict-aliasing switch for references",
5722                    gnat_node);
5723                 post_error_ne
5724                   ("\\?or use `pragma No_Strict_Aliasing (&);`",
5725                    gnat_node, Target_Type (gnat_node));
5726               }
5727           }
5728
5729         /* But if the result is a fat pointer type, we have no mechanism to
5730            do that, so we unconditionally warn in problematic cases.  */
5731         else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
5732           {
5733             tree gnu_source_array_type
5734               = TYPE_IS_FAT_POINTER_P (gnu_source_type)
5735                 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
5736                 : NULL_TREE;
5737             tree gnu_target_array_type
5738               = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
5739
5740             if ((TYPE_DUMMY_P (gnu_target_array_type)
5741                  || get_alias_set (gnu_target_array_type) != 0)
5742                 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
5743                     || (TYPE_DUMMY_P (gnu_source_array_type)
5744                         != TYPE_DUMMY_P (gnu_target_array_type))
5745                     || (TYPE_DUMMY_P (gnu_source_array_type)
5746                         && gnu_source_array_type != gnu_target_array_type)
5747                     || !alias_sets_conflict_p
5748                         (get_alias_set (gnu_source_array_type),
5749                          get_alias_set (gnu_target_array_type))))
5750               {
5751                 post_error_ne
5752                   ("?possible aliasing problem for type&",
5753                    gnat_node, Target_Type (gnat_node));
5754                 post_error
5755                   ("\\?use -fno-strict-aliasing switch for references",
5756                    gnat_node);
5757               }
5758           }
5759       }
5760       gnu_result = alloc_stmt_list ();
5761       break;
5762
5763     default:
5764       /* SCIL nodes require no processing for GCC.  Other nodes should only
5765          be present when annotating types.  */
5766       gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only);
5767       gnu_result = alloc_stmt_list ();
5768     }
5769
5770   /* If we pushed the processing of the elaboration routine, pop it back.  */
5771   if (went_into_elab_proc)
5772     current_function_decl = NULL_TREE;
5773
5774   /* When not optimizing, turn boolean rvalues B into B != false tests
5775      so that the code just below can put the location information of the
5776      reference to B on the inequality operator for better debug info.  */
5777   if (!optimize
5778       && TREE_CODE (gnu_result) != INTEGER_CST
5779       && (kind == N_Identifier
5780           || kind == N_Expanded_Name
5781           || kind == N_Explicit_Dereference
5782           || kind == N_Function_Call
5783           || kind == N_Indexed_Component
5784           || kind == N_Selected_Component)
5785       && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
5786       && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
5787     gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
5788                                   convert (gnu_result_type, gnu_result),
5789                                   convert (gnu_result_type,
5790                                            boolean_false_node));
5791
5792   /* Set the location information on the result.  Note that we may have
5793      no result if we tried to build a CALL_EXPR node to a procedure with
5794      no side-effects and optimization is enabled.  */
5795   if (gnu_result && EXPR_P (gnu_result))
5796     set_gnu_expr_location_from_node (gnu_result, gnat_node);
5797
5798   /* If we're supposed to return something of void_type, it means we have
5799      something we're elaborating for effect, so just return.  */
5800   if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5801     return gnu_result;
5802
5803   /* If the result is a constant that overflowed, raise Constraint_Error.  */
5804   if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
5805     {
5806       post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
5807       gnu_result
5808         = build1 (NULL_EXPR, gnu_result_type,
5809                   build_call_raise (CE_Overflow_Check_Failed, gnat_node,
5810                                     N_Raise_Constraint_Error));
5811     }
5812
5813   /* If our result has side-effects and is of an unconstrained type,
5814      make a SAVE_EXPR so that we can be sure it will only be referenced
5815      once.  Note we must do this before any conversions.  */
5816   if (TREE_SIDE_EFFECTS (gnu_result)
5817       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
5818           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
5819     gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
5820
5821   /* Now convert the result to the result type, unless we are in one of the
5822      following cases:
5823
5824        1. If this is the Name of an assignment statement or a parameter of
5825           a procedure call, return the result almost unmodified since the
5826           RHS will have to be converted to our type in that case, unless
5827           the result type has a simpler size.  Likewise if there is just
5828           a no-op unchecked conversion in-between.  Similarly, don't convert
5829           integral types that are the operands of an unchecked conversion
5830           since we need to ignore those conversions (for 'Valid).
5831
5832        2. If we have a label (which doesn't have any well-defined type), a
5833           field or an error, return the result almost unmodified.  Also don't
5834           do the conversion if the result type involves a PLACEHOLDER_EXPR in
5835           its size since those are the cases where the front end may have the
5836           type wrong due to "instantiating" the unconstrained record with
5837           discriminant values.  Similarly, if the two types are record types
5838           with the same name don't convert.  This will be the case when we are
5839           converting from a packable version of a type to its original type and
5840           we need those conversions to be NOPs in order for assignments into
5841           these types to work properly.
5842
5843        3. If the type is void or if we have no result, return error_mark_node
5844           to show we have no result.
5845
5846        4. Finally, if the type of the result is already correct.  */
5847
5848   if (Present (Parent (gnat_node))
5849       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
5850            && Name (Parent (gnat_node)) == gnat_node)
5851           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
5852               && unchecked_conversion_nop (Parent (gnat_node)))
5853           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
5854               && Name (Parent (gnat_node)) != gnat_node)
5855           || Nkind (Parent (gnat_node)) == N_Parameter_Association
5856           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
5857               && !AGGREGATE_TYPE_P (gnu_result_type)
5858               && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
5859       && !(TYPE_SIZE (gnu_result_type)
5860            && TYPE_SIZE (TREE_TYPE (gnu_result))
5861            && (AGGREGATE_TYPE_P (gnu_result_type)
5862                == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
5863            && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
5864                 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
5865                     != INTEGER_CST))
5866                || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
5867                    && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
5868                    && (CONTAINS_PLACEHOLDER_P
5869                        (TYPE_SIZE (TREE_TYPE (gnu_result))))))
5870            && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
5871                 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
5872     {
5873       /* Remove padding only if the inner object is of self-referential
5874          size: in that case it must be an object of unconstrained type
5875          with a default discriminant and we want to avoid copying too
5876          much data.  */
5877       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
5878           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
5879                                      (TREE_TYPE (gnu_result))))))
5880         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
5881                               gnu_result);
5882     }
5883
5884   else if (TREE_CODE (gnu_result) == LABEL_DECL
5885            || TREE_CODE (gnu_result) == FIELD_DECL
5886            || TREE_CODE (gnu_result) == ERROR_MARK
5887            || (TYPE_SIZE (gnu_result_type)
5888                && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
5889                && TREE_CODE (gnu_result) != INDIRECT_REF
5890                && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
5891            || ((TYPE_NAME (gnu_result_type)
5892                 == TYPE_NAME (TREE_TYPE (gnu_result)))
5893                && TREE_CODE (gnu_result_type) == RECORD_TYPE
5894                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
5895     {
5896       /* Remove any padding.  */
5897       if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
5898         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
5899                               gnu_result);
5900     }
5901
5902   else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
5903     gnu_result = error_mark_node;
5904
5905   else if (gnu_result_type != TREE_TYPE (gnu_result))
5906     gnu_result = convert (gnu_result_type, gnu_result);
5907
5908   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result.  */
5909   while ((TREE_CODE (gnu_result) == NOP_EXPR
5910           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
5911          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
5912     gnu_result = TREE_OPERAND (gnu_result, 0);
5913
5914   return gnu_result;
5915 }
5916 \f
5917 /* Subroutine of above to push the exception label stack.  GNU_STACK is
5918    a pointer to the stack to update and GNAT_LABEL, if present, is the
5919    label to push onto the stack.  */
5920
5921 static void
5922 push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label)
5923 {
5924   tree gnu_label = (Present (gnat_label)
5925                     ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
5926                     : NULL_TREE);
5927
5928   VEC_safe_push (tree, gc, *gnu_stack, gnu_label);
5929 }
5930 \f
5931 /* Record the current code position in GNAT_NODE.  */
5932
5933 static void
5934 record_code_position (Node_Id gnat_node)
5935 {
5936   tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
5937
5938   add_stmt_with_node (stmt_stmt, gnat_node);
5939   save_gnu_tree (gnat_node, stmt_stmt, true);
5940 }
5941
5942 /* Insert the code for GNAT_NODE at the position saved for that node.  */
5943
5944 static void
5945 insert_code_for (Node_Id gnat_node)
5946 {
5947   STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
5948   save_gnu_tree (gnat_node, NULL_TREE, true);
5949 }
5950 \f
5951 /* Start a new statement group chained to the previous group.  */
5952
5953 void
5954 start_stmt_group (void)
5955 {
5956   struct stmt_group *group = stmt_group_free_list;
5957
5958   /* First see if we can get one from the free list.  */
5959   if (group)
5960     stmt_group_free_list = group->previous;
5961   else
5962     group = ggc_alloc_stmt_group ();
5963
5964   group->previous = current_stmt_group;
5965   group->stmt_list = group->block = group->cleanups = NULL_TREE;
5966   current_stmt_group = group;
5967 }
5968
5969 /* Add GNU_STMT to the current statement group.  If it is an expression with
5970    no effects, it is ignored.  */
5971
5972 void
5973 add_stmt (tree gnu_stmt)
5974 {
5975   append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
5976 }
5977
5978 /* Similar, but the statement is always added, regardless of side-effects.  */
5979
5980 void
5981 add_stmt_force (tree gnu_stmt)
5982 {
5983   append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
5984 }
5985
5986 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE.  */
5987
5988 void
5989 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
5990 {
5991   if (Present (gnat_node))
5992     set_expr_location_from_node (gnu_stmt, gnat_node);
5993   add_stmt (gnu_stmt);
5994 }
5995
5996 /* Similar, but the statement is always added, regardless of side-effects.  */
5997
5998 void
5999 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
6000 {
6001   if (Present (gnat_node))
6002     set_expr_location_from_node (gnu_stmt, gnat_node);
6003   add_stmt_force (gnu_stmt);
6004 }
6005
6006 /* Add a declaration statement for GNU_DECL to the current statement group.
6007    Get SLOC from Entity_Id.  */
6008
6009 void
6010 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
6011 {
6012   tree type = TREE_TYPE (gnu_decl);
6013   tree gnu_stmt, gnu_init, t;
6014
6015   /* If this is a variable that Gigi is to ignore, we may have been given
6016      an ERROR_MARK.  So test for it.  We also might have been given a
6017      reference for a renaming.  So only do something for a decl.  Also
6018      ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE.  */
6019   if (!DECL_P (gnu_decl)
6020       || (TREE_CODE (gnu_decl) == TYPE_DECL
6021           && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
6022     return;
6023
6024   gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
6025
6026   /* If we are global, we don't want to actually output the DECL_EXPR for
6027      this decl since we already have evaluated the expressions in the
6028      sizes and positions as globals and doing it again would be wrong.  */
6029   if (global_bindings_p ())
6030     {
6031       /* Mark everything as used to prevent node sharing with subprograms.
6032          Note that walk_tree knows how to deal with TYPE_DECL, but neither
6033          VAR_DECL nor CONST_DECL.  This appears to be somewhat arbitrary.  */
6034       MARK_VISITED (gnu_stmt);
6035       if (TREE_CODE (gnu_decl) == VAR_DECL
6036           || TREE_CODE (gnu_decl) == CONST_DECL)
6037         {
6038           MARK_VISITED (DECL_SIZE (gnu_decl));
6039           MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
6040           MARK_VISITED (DECL_INITIAL (gnu_decl));
6041         }
6042       /* In any case, we have to deal with our own TYPE_ADA_SIZE field.  */
6043       else if (TREE_CODE (gnu_decl) == TYPE_DECL
6044                && ((TREE_CODE (type) == RECORD_TYPE
6045                     && !TYPE_FAT_POINTER_P (type))
6046                    || TREE_CODE (type) == UNION_TYPE
6047                    || TREE_CODE (type) == QUAL_UNION_TYPE))
6048         MARK_VISITED (TYPE_ADA_SIZE (type));
6049     }
6050   else if (!DECL_EXTERNAL (gnu_decl))
6051     add_stmt_with_node (gnu_stmt, gnat_entity);
6052
6053   /* If this is a variable and an initializer is attached to it, it must be
6054      valid for the context.  Similar to init_const in create_var_decl_1.  */
6055   if (TREE_CODE (gnu_decl) == VAR_DECL
6056       && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
6057       && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
6058           || (TREE_STATIC (gnu_decl)
6059               && !initializer_constant_valid_p (gnu_init,
6060                                                 TREE_TYPE (gnu_init)))))
6061     {
6062       /* If GNU_DECL has a padded type, convert it to the unpadded
6063          type so the assignment is done properly.  */
6064       if (TYPE_IS_PADDING_P (type))
6065         t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
6066       else
6067         t = gnu_decl;
6068
6069       gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
6070
6071       DECL_INITIAL (gnu_decl) = NULL_TREE;
6072       if (TREE_READONLY (gnu_decl))
6073         {
6074           TREE_READONLY (gnu_decl) = 0;
6075           DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
6076         }
6077
6078       add_stmt_with_node (gnu_stmt, gnat_entity);
6079     }
6080 }
6081
6082 /* Callback for walk_tree to mark the visited trees rooted at *TP.  */
6083
6084 static tree
6085 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
6086 {
6087   tree t = *tp;
6088
6089   if (TREE_VISITED (t))
6090     *walk_subtrees = 0;
6091
6092   /* Don't mark a dummy type as visited because we want to mark its sizes
6093      and fields once it's filled in.  */
6094   else if (!TYPE_IS_DUMMY_P (t))
6095     TREE_VISITED (t) = 1;
6096
6097   if (TYPE_P (t))
6098     TYPE_SIZES_GIMPLIFIED (t) = 1;
6099
6100   return NULL_TREE;
6101 }
6102
6103 /* Mark nodes rooted at T with TREE_VISITED and types as having their
6104    sized gimplified.  We use this to indicate all variable sizes and
6105    positions in global types may not be shared by any subprogram.  */
6106
6107 void
6108 mark_visited (tree t)
6109 {
6110   walk_tree (&t, mark_visited_r, NULL, NULL);
6111 }
6112
6113 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
6114    set its location to that of GNAT_NODE if present.  */
6115
6116 static void
6117 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
6118 {
6119   if (Present (gnat_node))
6120     set_expr_location_from_node (gnu_cleanup, gnat_node);
6121   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
6122 }
6123
6124 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
6125
6126 void
6127 set_block_for_group (tree gnu_block)
6128 {
6129   gcc_assert (!current_stmt_group->block);
6130   current_stmt_group->block = gnu_block;
6131 }
6132
6133 /* Return code corresponding to the current code group.  It is normally
6134    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
6135    BLOCK or cleanups were set.  */
6136
6137 tree
6138 end_stmt_group (void)
6139 {
6140   struct stmt_group *group = current_stmt_group;
6141   tree gnu_retval = group->stmt_list;
6142
6143   /* If this is a null list, allocate a new STATEMENT_LIST.  Then, if there
6144      are cleanups, make a TRY_FINALLY_EXPR.  Last, if there is a BLOCK,
6145      make a BIND_EXPR.  Note that we nest in that because the cleanup may
6146      reference variables in the block.  */
6147   if (gnu_retval == NULL_TREE)
6148     gnu_retval = alloc_stmt_list ();
6149
6150   if (group->cleanups)
6151     gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
6152                          group->cleanups);
6153
6154   if (current_stmt_group->block)
6155     gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
6156                          gnu_retval, group->block);
6157
6158   /* Remove this group from the stack and add it to the free list.  */
6159   current_stmt_group = group->previous;
6160   group->previous = stmt_group_free_list;
6161   stmt_group_free_list = group;
6162
6163   return gnu_retval;
6164 }
6165
6166 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
6167    statements.*/
6168
6169 static void
6170 add_stmt_list (List_Id gnat_list)
6171 {
6172   Node_Id gnat_node;
6173
6174   if (Present (gnat_list))
6175     for (gnat_node = First (gnat_list); Present (gnat_node);
6176          gnat_node = Next (gnat_node))
6177       add_stmt (gnat_to_gnu (gnat_node));
6178 }
6179
6180 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
6181    If BINDING_P is true, push and pop a binding level around the list.  */
6182
6183 static tree
6184 build_stmt_group (List_Id gnat_list, bool binding_p)
6185 {
6186   start_stmt_group ();
6187   if (binding_p)
6188     gnat_pushlevel ();
6189
6190   add_stmt_list (gnat_list);
6191   if (binding_p)
6192     gnat_poplevel ();
6193
6194   return end_stmt_group ();
6195 }
6196 \f
6197 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
6198
6199 int
6200 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
6201                     gimple_seq *post_p ATTRIBUTE_UNUSED)
6202 {
6203   tree expr = *expr_p;
6204   tree op;
6205
6206   if (IS_ADA_STMT (expr))
6207     return gnat_gimplify_stmt (expr_p);
6208
6209   switch (TREE_CODE (expr))
6210     {
6211     case NULL_EXPR:
6212       /* If this is for a scalar, just make a VAR_DECL for it.  If for
6213          an aggregate, get a null pointer of the appropriate type and
6214          dereference it.  */
6215       if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
6216         *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
6217                           convert (build_pointer_type (TREE_TYPE (expr)),
6218                                    integer_zero_node));
6219       else
6220         {
6221           *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
6222           TREE_NO_WARNING (*expr_p) = 1;
6223         }
6224
6225       gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
6226       return GS_OK;
6227
6228     case UNCONSTRAINED_ARRAY_REF:
6229       /* We should only do this if we are just elaborating for side-effects,
6230          but we can't know that yet.  */
6231       *expr_p = TREE_OPERAND (*expr_p, 0);
6232       return GS_OK;
6233
6234     case ADDR_EXPR:
6235       op = TREE_OPERAND (expr, 0);
6236
6237       /* If we are taking the address of a constant CONSTRUCTOR, make sure it
6238          is put into static memory.  We know that it's going to be read-only
6239          given the semantics we have and it must be in static memory when the
6240          reference is in an elaboration procedure.  */
6241       if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
6242         {
6243           tree addr = build_fold_addr_expr (tree_output_constant_def (op));
6244           *expr_p = fold_convert (TREE_TYPE (expr), addr);
6245           return GS_ALL_DONE;
6246         }
6247
6248       /* Otherwise, if we are taking the address of a non-constant CONSTRUCTOR
6249          or of a call, explicitly create the local temporary.  That's required
6250          if the type is passed by reference.  */
6251       if (TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
6252         {
6253           tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
6254           TREE_ADDRESSABLE (new_var) = 1;
6255           gimple_add_tmp_var (new_var);
6256
6257           mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
6258           gimplify_and_add (mod, pre_p);
6259
6260           TREE_OPERAND (expr, 0) = new_var;
6261           recompute_tree_invariant_for_addr_expr (expr);
6262           return GS_ALL_DONE;
6263         }
6264
6265       return GS_UNHANDLED;
6266
6267     case DECL_EXPR:
6268       op = DECL_EXPR_DECL (expr);
6269
6270       /* The expressions for the RM bounds must be gimplified to ensure that
6271          they are properly elaborated.  See gimplify_decl_expr.  */
6272       if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
6273           && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
6274         switch (TREE_CODE (TREE_TYPE (op)))
6275           {
6276           case INTEGER_TYPE:
6277           case ENUMERAL_TYPE:
6278           case BOOLEAN_TYPE:
6279           case REAL_TYPE:
6280             {
6281               tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
6282
6283               val = TYPE_RM_MIN_VALUE (type);
6284               if (val)
6285                 {
6286                   gimplify_one_sizepos (&val, pre_p);
6287                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
6288                     SET_TYPE_RM_MIN_VALUE (t, val);
6289                 }
6290
6291               val = TYPE_RM_MAX_VALUE (type);
6292               if (val)
6293                 {
6294                   gimplify_one_sizepos (&val, pre_p);
6295                   for (t = type; t; t = TYPE_NEXT_VARIANT (t))
6296                     SET_TYPE_RM_MAX_VALUE (t, val);
6297                 }
6298
6299             }
6300             break;
6301
6302           default:
6303             break;
6304           }
6305
6306       /* ... fall through ... */
6307
6308     default:
6309       return GS_UNHANDLED;
6310     }
6311 }
6312
6313 /* Generate GIMPLE in place for the statement at *STMT_P.  */
6314
6315 static enum gimplify_status
6316 gnat_gimplify_stmt (tree *stmt_p)
6317 {
6318   tree stmt = *stmt_p;
6319
6320   switch (TREE_CODE (stmt))
6321     {
6322     case STMT_STMT:
6323       *stmt_p = STMT_STMT_STMT (stmt);
6324       return GS_OK;
6325
6326     case LOOP_STMT:
6327       {
6328         tree gnu_start_label = create_artificial_label (input_location);
6329         tree gnu_cond = LOOP_STMT_COND (stmt);
6330         tree gnu_update = LOOP_STMT_UPDATE (stmt);
6331         tree gnu_end_label = LOOP_STMT_LABEL (stmt);
6332         tree t;
6333
6334         /* Build the condition expression from the test, if any.  */
6335         if (gnu_cond)
6336           gnu_cond
6337             = build3 (COND_EXPR, void_type_node, gnu_cond, alloc_stmt_list (),
6338                       build1 (GOTO_EXPR, void_type_node, gnu_end_label));
6339
6340         /* Set to emit the statements of the loop.  */
6341         *stmt_p = NULL_TREE;
6342
6343         /* We first emit the start label and then a conditional jump to the
6344            end label if there's a top condition, then the update if it's at
6345            the top, then the body of the loop, then a conditional jump to
6346            the end label if there's a bottom condition, then the update if
6347            it's at the bottom, and finally a jump to the start label and the
6348            definition of the end label.  */
6349         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
6350                                           gnu_start_label),
6351                                   stmt_p);
6352
6353         if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
6354           append_to_statement_list (gnu_cond, stmt_p);
6355
6356         if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
6357           append_to_statement_list (gnu_update, stmt_p);
6358
6359         append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
6360
6361         if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
6362           append_to_statement_list (gnu_cond, stmt_p);
6363
6364         if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
6365           append_to_statement_list (gnu_update, stmt_p);
6366
6367         t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
6368         SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
6369         append_to_statement_list (t, stmt_p);
6370
6371         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
6372                                           gnu_end_label),
6373                                   stmt_p);
6374         return GS_OK;
6375       }
6376
6377     case EXIT_STMT:
6378       /* Build a statement to jump to the corresponding end label, then
6379          see if it needs to be conditional.  */
6380       *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
6381       if (EXIT_STMT_COND (stmt))
6382         *stmt_p = build3 (COND_EXPR, void_type_node,
6383                           EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
6384       return GS_OK;
6385
6386     default:
6387       gcc_unreachable ();
6388     }
6389 }
6390 \f
6391 /* Force references to each of the entities in packages withed by GNAT_NODE.
6392    Operate recursively but check that we aren't elaborating something more
6393    than once.
6394
6395    This routine is exclusively called in type_annotate mode, to compute DDA
6396    information for types in withed units, for ASIS use.  */
6397
6398 static void
6399 elaborate_all_entities (Node_Id gnat_node)
6400 {
6401   Entity_Id gnat_with_clause, gnat_entity;
6402
6403   /* Process each unit only once.  As we trace the context of all relevant
6404      units transitively, including generic bodies, we may encounter the
6405      same generic unit repeatedly.  */
6406   if (!present_gnu_tree (gnat_node))
6407      save_gnu_tree (gnat_node, integer_zero_node, true);
6408
6409   /* Save entities in all context units.  A body may have an implicit_with
6410      on its own spec, if the context includes a child unit, so don't save
6411      the spec twice.  */
6412   for (gnat_with_clause = First (Context_Items (gnat_node));
6413        Present (gnat_with_clause);
6414        gnat_with_clause = Next (gnat_with_clause))
6415     if (Nkind (gnat_with_clause) == N_With_Clause
6416         && !present_gnu_tree (Library_Unit (gnat_with_clause))
6417         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
6418       {
6419         elaborate_all_entities (Library_Unit (gnat_with_clause));
6420
6421         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
6422           {
6423             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
6424                  Present (gnat_entity);
6425                  gnat_entity = Next_Entity (gnat_entity))
6426               if (Is_Public (gnat_entity)
6427                   && Convention (gnat_entity) != Convention_Intrinsic
6428                   && Ekind (gnat_entity) != E_Package
6429                   && Ekind (gnat_entity) != E_Package_Body
6430                   && Ekind (gnat_entity) != E_Operator
6431                   && !(IN (Ekind (gnat_entity), Type_Kind)
6432                        && !Is_Frozen (gnat_entity))
6433                   && !((Ekind (gnat_entity) == E_Procedure
6434                         || Ekind (gnat_entity) == E_Function)
6435                        && Is_Intrinsic_Subprogram (gnat_entity))
6436                   && !IN (Ekind (gnat_entity), Named_Kind)
6437                   && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
6438                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
6439           }
6440         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
6441           {
6442             Node_Id gnat_body
6443               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
6444
6445             /* Retrieve compilation unit node of generic body.  */
6446             while (Present (gnat_body)
6447                    && Nkind (gnat_body) != N_Compilation_Unit)
6448               gnat_body = Parent (gnat_body);
6449
6450             /* If body is available, elaborate its context.  */
6451             if (Present (gnat_body))
6452               elaborate_all_entities (gnat_body);
6453           }
6454       }
6455
6456   if (Nkind (Unit (gnat_node)) == N_Package_Body)
6457     elaborate_all_entities (Library_Unit (gnat_node));
6458 }
6459 \f
6460 /* Do the processing of GNAT_NODE, an N_Freeze_Entity.  */
6461
6462 static void
6463 process_freeze_entity (Node_Id gnat_node)
6464 {
6465   const Entity_Id gnat_entity = Entity (gnat_node);
6466   const Entity_Kind kind = Ekind (gnat_entity);
6467   tree gnu_old, gnu_new;
6468
6469   /* If this is a package, we need to generate code for the package.  */
6470   if (kind == E_Package)
6471     {
6472       insert_code_for
6473         (Parent (Corresponding_Body
6474                  (Parent (Declaration_Node (gnat_entity)))));
6475       return;
6476     }
6477
6478   /* Don't do anything for class-wide types as they are always transformed
6479      into their root type.  */
6480   if (kind == E_Class_Wide_Type)
6481     return;
6482
6483   /* Check for an old definition.  This freeze node might be for an Itype.  */
6484   gnu_old
6485     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
6486
6487   /* If this entity has an address representation clause, GNU_OLD is the
6488      address, so discard it here.  */
6489   if (Present (Address_Clause (gnat_entity)))
6490     gnu_old = NULL_TREE;
6491
6492   /* Don't do anything for subprograms that may have been elaborated before
6493      their freeze nodes.  This can happen, for example, because of an inner
6494      call in an instance body or because of previous compilation of a spec
6495      for inlining purposes.  */
6496   if (gnu_old
6497       && ((TREE_CODE (gnu_old) == FUNCTION_DECL
6498            && (kind == E_Function || kind == E_Procedure))
6499           || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
6500               && kind == E_Subprogram_Type)))
6501     return;
6502
6503   /* If we have a non-dummy type old tree, we have nothing to do, except
6504      aborting if this is the public view of a private type whose full view was
6505      not delayed, as this node was never delayed as it should have been.  We
6506      let this happen for concurrent types and their Corresponding_Record_Type,
6507      however, because each might legitimately be elaborated before its own
6508      freeze node, e.g. while processing the other.  */
6509   if (gnu_old
6510       && !(TREE_CODE (gnu_old) == TYPE_DECL
6511            && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
6512     {
6513       gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
6514                    && Present (Full_View (gnat_entity))
6515                    && No (Freeze_Node (Full_View (gnat_entity))))
6516                   || Is_Concurrent_Type (gnat_entity)
6517                   || (IN (kind, Record_Kind)
6518                       && Is_Concurrent_Record_Type (gnat_entity)));
6519       return;
6520     }
6521
6522   /* Reset the saved tree, if any, and elaborate the object or type for real.
6523      If there is a full view, elaborate it and use the result.  And, if this
6524      is the root type of a class-wide type, reuse it for the latter.  */
6525   if (gnu_old)
6526     {
6527       save_gnu_tree (gnat_entity, NULL_TREE, false);
6528       if (IN (kind, Incomplete_Or_Private_Kind)
6529           && Present (Full_View (gnat_entity))
6530           && present_gnu_tree (Full_View (gnat_entity)))
6531         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
6532       if (IN (kind, Type_Kind)
6533           && Present (Class_Wide_Type (gnat_entity))
6534           && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6535         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
6536     }
6537
6538   if (IN (kind, Incomplete_Or_Private_Kind)
6539       && Present (Full_View (gnat_entity)))
6540     {
6541       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
6542
6543       /* Propagate back-annotations from full view to partial view.  */
6544       if (Unknown_Alignment (gnat_entity))
6545         Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
6546
6547       if (Unknown_Esize (gnat_entity))
6548         Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
6549
6550       if (Unknown_RM_Size (gnat_entity))
6551         Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
6552
6553       /* The above call may have defined this entity (the simplest example
6554          of this is when we have a private enumeral type since the bounds
6555          will have the public view).  */
6556       if (!present_gnu_tree (gnat_entity))
6557         save_gnu_tree (gnat_entity, gnu_new, false);
6558     }
6559   else
6560     {
6561       tree gnu_init
6562         = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
6563            && present_gnu_tree (Declaration_Node (gnat_entity)))
6564           ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
6565
6566       gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
6567     }
6568
6569   if (IN (kind, Type_Kind)
6570       && Present (Class_Wide_Type (gnat_entity))
6571       && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6572     save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
6573
6574   /* If we've made any pointers to the old version of this type, we
6575      have to update them.  */
6576   if (gnu_old)
6577     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
6578                        TREE_TYPE (gnu_new));
6579 }
6580 \f
6581 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
6582    We make two passes, one to elaborate anything other than bodies (but
6583    we declare a function if there was no spec).  The second pass
6584    elaborates the bodies.
6585
6586    GNAT_END_LIST gives the element in the list past the end.  Normally,
6587    this is Empty, but can be First_Real_Statement for a
6588    Handled_Sequence_Of_Statements.
6589
6590    We make a complete pass through both lists if PASS1P is true, then make
6591    the second pass over both lists if PASS2P is true.  The lists usually
6592    correspond to the public and private parts of a package.  */
6593
6594 static void
6595 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
6596                Node_Id gnat_end_list, bool pass1p, bool pass2p)
6597 {
6598   List_Id gnat_decl_array[2];
6599   Node_Id gnat_decl;
6600   int i;
6601
6602   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
6603
6604   if (pass1p)
6605     for (i = 0; i <= 1; i++)
6606       if (Present (gnat_decl_array[i]))
6607         for (gnat_decl = First (gnat_decl_array[i]);
6608              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6609           {
6610             /* For package specs, we recurse inside the declarations,
6611                thus taking the two pass approach inside the boundary.  */
6612             if (Nkind (gnat_decl) == N_Package_Declaration
6613                 && (Nkind (Specification (gnat_decl)
6614                            == N_Package_Specification)))
6615               process_decls (Visible_Declarations (Specification (gnat_decl)),
6616                              Private_Declarations (Specification (gnat_decl)),
6617                              Empty, true, false);
6618
6619             /* Similarly for any declarations in the actions of a
6620                freeze node.  */
6621             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6622               {
6623                 process_freeze_entity (gnat_decl);
6624                 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
6625               }
6626
6627             /* Package bodies with freeze nodes get their elaboration deferred
6628                until the freeze node, but the code must be placed in the right
6629                place, so record the code position now.  */
6630             else if (Nkind (gnat_decl) == N_Package_Body
6631                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
6632               record_code_position (gnat_decl);
6633
6634             else if (Nkind (gnat_decl) == N_Package_Body_Stub
6635                      && Present (Library_Unit (gnat_decl))
6636                      && Present (Freeze_Node
6637                                  (Corresponding_Spec
6638                                   (Proper_Body (Unit
6639                                                 (Library_Unit (gnat_decl)))))))
6640               record_code_position
6641                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
6642
6643             /* We defer most subprogram bodies to the second pass.  */
6644             else if (Nkind (gnat_decl) == N_Subprogram_Body)
6645               {
6646                 if (Acts_As_Spec (gnat_decl))
6647                   {
6648                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
6649
6650                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
6651                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6652                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6653                   }
6654               }
6655
6656             /* For bodies and stubs that act as their own specs, the entity
6657                itself must be elaborated in the first pass, because it may
6658                be used in other declarations.  */
6659             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
6660               {
6661                 Node_Id gnat_subprog_id
6662                   = Defining_Entity (Specification (gnat_decl));
6663
6664                     if (Ekind (gnat_subprog_id) != E_Subprogram_Body
6665                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
6666                         && Ekind (gnat_subprog_id) != E_Generic_Function)
6667                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6668               }
6669
6670             /* Concurrent stubs stand for the corresponding subprogram bodies,
6671                which are deferred like other bodies.  */
6672             else if (Nkind (gnat_decl) == N_Task_Body_Stub
6673                      || Nkind (gnat_decl) == N_Protected_Body_Stub)
6674               ;
6675
6676             else
6677               add_stmt (gnat_to_gnu (gnat_decl));
6678           }
6679
6680   /* Here we elaborate everything we deferred above except for package bodies,
6681      which are elaborated at their freeze nodes.  Note that we must also
6682      go inside things (package specs and freeze nodes) the first pass did.  */
6683   if (pass2p)
6684     for (i = 0; i <= 1; i++)
6685       if (Present (gnat_decl_array[i]))
6686         for (gnat_decl = First (gnat_decl_array[i]);
6687              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6688           {
6689             if (Nkind (gnat_decl) == N_Subprogram_Body
6690                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
6691                 || Nkind (gnat_decl) == N_Task_Body_Stub
6692                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
6693               add_stmt (gnat_to_gnu (gnat_decl));
6694
6695             else if (Nkind (gnat_decl) == N_Package_Declaration
6696                      && (Nkind (Specification (gnat_decl)
6697                                 == N_Package_Specification)))
6698               process_decls (Visible_Declarations (Specification (gnat_decl)),
6699                              Private_Declarations (Specification (gnat_decl)),
6700                              Empty, false, true);
6701
6702             else if (Nkind (gnat_decl) == N_Freeze_Entity)
6703               process_decls (Actions (gnat_decl), Empty, Empty, false, true);
6704           }
6705 }
6706 \f
6707 /* Make a unary operation of kind CODE using build_unary_op, but guard
6708    the operation by an overflow check.  CODE can be one of NEGATE_EXPR
6709    or ABS_EXPR.  GNU_TYPE is the type desired for the result.  Usually
6710    the operation is to be performed in that type.  GNAT_NODE is the gnat
6711    node conveying the source location for which the error should be
6712    signaled.  */
6713
6714 static tree
6715 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
6716                       Node_Id gnat_node)
6717 {
6718   gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
6719
6720   operand = gnat_protect_expr (operand);
6721
6722   return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
6723                                       operand, TYPE_MIN_VALUE (gnu_type)),
6724                      build_unary_op (code, gnu_type, operand),
6725                      CE_Overflow_Check_Failed, gnat_node);
6726 }
6727
6728 /* Make a binary operation of kind CODE using build_binary_op, but guard
6729    the operation by an overflow check.  CODE can be one of PLUS_EXPR,
6730    MINUS_EXPR or MULT_EXPR.  GNU_TYPE is the type desired for the result.
6731    Usually the operation is to be performed in that type.  GNAT_NODE is
6732    the GNAT node conveying the source location for which the error should
6733    be signaled.  */
6734
6735 static tree
6736 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
6737                        tree right, Node_Id gnat_node)
6738 {
6739   tree lhs = gnat_protect_expr (left);
6740   tree rhs = gnat_protect_expr (right);
6741   tree type_max = TYPE_MAX_VALUE (gnu_type);
6742   tree type_min = TYPE_MIN_VALUE (gnu_type);
6743   tree gnu_expr;
6744   tree tmp1, tmp2;
6745   tree zero = convert (gnu_type, integer_zero_node);
6746   tree rhs_lt_zero;
6747   tree check_pos;
6748   tree check_neg;
6749   tree check;
6750   int precision = TYPE_PRECISION (gnu_type);
6751
6752   gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */
6753
6754   /* Prefer a constant or known-positive rhs to simplify checks.  */
6755   if (!TREE_CONSTANT (rhs)
6756       && commutative_tree_code (code)
6757       && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs)
6758                                   && tree_expr_nonnegative_p (lhs))))
6759     {
6760       tree tmp = lhs;
6761       lhs = rhs;
6762       rhs = tmp;
6763     }
6764
6765   rhs_lt_zero = tree_expr_nonnegative_p (rhs)
6766                 ? boolean_false_node
6767                 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
6768
6769   /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
6770
6771   /* Try a few strategies that may be cheaper than the general
6772      code at the end of the function, if the rhs is not known.
6773      The strategies are:
6774        - Call library function for 64-bit multiplication (complex)
6775        - Widen, if input arguments are sufficiently small
6776        - Determine overflow using wrapped result for addition/subtraction.  */
6777
6778   if (!TREE_CONSTANT (rhs))
6779     {
6780       /* Even for add/subtract double size to get another base type.  */
6781       int needed_precision = precision * 2;
6782
6783       if (code == MULT_EXPR && precision == 64)
6784         {
6785           tree int_64 = gnat_type_for_size (64, 0);
6786
6787           return convert (gnu_type, build_call_2_expr (mulv64_decl,
6788                                                        convert (int_64, lhs),
6789                                                        convert (int_64, rhs)));
6790         }
6791
6792       else if (needed_precision <= BITS_PER_WORD
6793                || (code == MULT_EXPR
6794                    && needed_precision <= LONG_LONG_TYPE_SIZE))
6795         {
6796           tree wide_type = gnat_type_for_size (needed_precision, 0);
6797
6798           tree wide_result = build_binary_op (code, wide_type,
6799                                               convert (wide_type, lhs),
6800                                               convert (wide_type, rhs));
6801
6802           tree check = build_binary_op
6803             (TRUTH_ORIF_EXPR, boolean_type_node,
6804              build_binary_op (LT_EXPR, boolean_type_node, wide_result,
6805                               convert (wide_type, type_min)),
6806              build_binary_op (GT_EXPR, boolean_type_node, wide_result,
6807                               convert (wide_type, type_max)));
6808
6809           tree result = convert (gnu_type, wide_result);
6810
6811           return
6812             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
6813         }
6814
6815       else if (code == PLUS_EXPR || code == MINUS_EXPR)
6816         {
6817           tree unsigned_type = gnat_type_for_size (precision, 1);
6818           tree wrapped_expr = convert
6819             (gnu_type, build_binary_op (code, unsigned_type,
6820                                         convert (unsigned_type, lhs),
6821                                         convert (unsigned_type, rhs)));
6822
6823           tree result = convert
6824             (gnu_type, build_binary_op (code, gnu_type, lhs, rhs));
6825
6826           /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
6827              or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction.  */
6828           tree check = build_binary_op
6829             (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
6830              build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
6831                               boolean_type_node, wrapped_expr, lhs));
6832
6833           return
6834             emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
6835         }
6836    }
6837
6838   switch (code)
6839     {
6840     case PLUS_EXPR:
6841       /* When rhs >= 0, overflow when lhs > type_max - rhs.  */
6842       check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
6843                                    build_binary_op (MINUS_EXPR, gnu_type,
6844                                                     type_max, rhs)),
6845
6846       /* When rhs < 0, overflow when lhs < type_min - rhs.  */
6847       check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
6848                                    build_binary_op (MINUS_EXPR, gnu_type,
6849                                                     type_min, rhs));
6850       break;
6851
6852     case MINUS_EXPR:
6853       /* When rhs >= 0, overflow when lhs < type_min + rhs.  */
6854       check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
6855                                    build_binary_op (PLUS_EXPR, gnu_type,
6856                                                     type_min, rhs)),
6857
6858       /* When rhs < 0, overflow when lhs > type_max + rhs.  */
6859       check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
6860                                    build_binary_op (PLUS_EXPR, gnu_type,
6861                                                     type_max, rhs));
6862       break;
6863
6864     case MULT_EXPR:
6865       /* The check here is designed to be efficient if the rhs is constant,
6866          but it will work for any rhs by using integer division.
6867          Four different check expressions determine whether X * C overflows,
6868          depending on C.
6869            C ==  0  =>  false
6870            C  >  0  =>  X > type_max / C || X < type_min / C
6871            C == -1  =>  X == type_min
6872            C  < -1  =>  X > type_min / C || X < type_max / C */
6873
6874       tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
6875       tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
6876
6877       check_pos
6878         = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6879                            build_binary_op (NE_EXPR, boolean_type_node, zero,
6880                                             rhs),
6881                            build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
6882                                             build_binary_op (GT_EXPR,
6883                                                              boolean_type_node,
6884                                                              lhs, tmp1),
6885                                             build_binary_op (LT_EXPR,
6886                                                              boolean_type_node,
6887                                                              lhs, tmp2)));
6888
6889       check_neg
6890         = fold_build3 (COND_EXPR, boolean_type_node,
6891                        build_binary_op (EQ_EXPR, boolean_type_node, rhs,
6892                                         build_int_cst (gnu_type, -1)),
6893                        build_binary_op (EQ_EXPR, boolean_type_node, lhs,
6894                                         type_min),
6895                        build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
6896                                         build_binary_op (GT_EXPR,
6897                                                          boolean_type_node,
6898                                                          lhs, tmp2),
6899                                         build_binary_op (LT_EXPR,
6900                                                          boolean_type_node,
6901                                                          lhs, tmp1)));
6902       break;
6903
6904     default:
6905       gcc_unreachable();
6906     }
6907
6908   gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
6909
6910   /* If we can fold the expression to a constant, just return it.
6911      The caller will deal with overflow, no need to generate a check.  */
6912   if (TREE_CONSTANT (gnu_expr))
6913     return gnu_expr;
6914
6915   check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
6916                        check_pos);
6917
6918   return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
6919 }
6920
6921 /* Emit code for a range check.  GNU_EXPR is the expression to be checked,
6922    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
6923    which we have to check.  GNAT_NODE is the GNAT node conveying the source
6924    location for which the error should be signaled.  */
6925
6926 static tree
6927 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
6928 {
6929   tree gnu_range_type = get_unpadded_type (gnat_range_type);
6930   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
6931   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
6932   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
6933
6934   /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
6935      This can for example happen when translating 'Val or 'Value.  */
6936   if (gnu_compare_type == gnu_range_type)
6937     return gnu_expr;
6938
6939   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
6940      we can't do anything since we might be truncating the bounds.  No
6941      check is needed in this case.  */
6942   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
6943       && (TYPE_PRECISION (gnu_compare_type)
6944           < TYPE_PRECISION (get_base_type (gnu_range_type))))
6945     return gnu_expr;
6946
6947   /* Checked expressions must be evaluated only once.  */
6948   gnu_expr = gnat_protect_expr (gnu_expr);
6949
6950   /* Note that the form of the check is
6951         (not (expr >= lo)) or (not (expr <= hi))
6952      the reason for this slightly convoluted form is that NaNs
6953      are not considered to be in range in the float case.  */
6954   return emit_check
6955     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
6956                       invert_truthvalue
6957                       (build_binary_op (GE_EXPR, boolean_type_node,
6958                                        convert (gnu_compare_type, gnu_expr),
6959                                        convert (gnu_compare_type, gnu_low))),
6960                       invert_truthvalue
6961                       (build_binary_op (LE_EXPR, boolean_type_node,
6962                                         convert (gnu_compare_type, gnu_expr),
6963                                         convert (gnu_compare_type,
6964                                                  gnu_high)))),
6965      gnu_expr, CE_Range_Check_Failed, gnat_node);
6966 }
6967 \f
6968 /* Emit code for an index check.  GNU_ARRAY_OBJECT is the array object which
6969    we are about to index, GNU_EXPR is the index expression to be checked,
6970    GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
6971    has to be checked.  Note that for index checking we cannot simply use the
6972    emit_range_check function (although very similar code needs to be generated
6973    in both cases) since for index checking the array type against which we are
6974    checking the indices may be unconstrained and consequently we need to get
6975    the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
6976    The place where we need to do that is in subprograms having unconstrained
6977    array formal parameters.  GNAT_NODE is the GNAT node conveying the source
6978    location for which the error should be signaled.  */
6979
6980 static tree
6981 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
6982                   tree gnu_high, Node_Id gnat_node)
6983 {
6984   tree gnu_expr_check;
6985
6986   /* Checked expressions must be evaluated only once.  */
6987   gnu_expr = gnat_protect_expr (gnu_expr);
6988
6989   /* Must do this computation in the base type in case the expression's
6990      type is an unsigned subtypes.  */
6991   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
6992
6993   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
6994      the object we are handling.  */
6995   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
6996   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
6997
6998   return emit_check
6999     (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
7000                       build_binary_op (LT_EXPR, boolean_type_node,
7001                                        gnu_expr_check,
7002                                        convert (TREE_TYPE (gnu_expr_check),
7003                                                 gnu_low)),
7004                       build_binary_op (GT_EXPR, boolean_type_node,
7005                                        gnu_expr_check,
7006                                        convert (TREE_TYPE (gnu_expr_check),
7007                                                 gnu_high))),
7008      gnu_expr, CE_Index_Check_Failed, gnat_node);
7009 }
7010 \f
7011 /* GNU_COND contains the condition corresponding to an access, discriminant or
7012    range check of value GNU_EXPR.  Build a COND_EXPR that returns GNU_EXPR if
7013    GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
7014    REASON is the code that says why the exception was raised.  GNAT_NODE is
7015    the GNAT node conveying the source location for which the error should be
7016    signaled.  */
7017
7018 static tree
7019 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
7020 {
7021   tree gnu_call
7022     = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
7023   tree gnu_result
7024     = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
7025                    build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
7026                            convert (TREE_TYPE (gnu_expr), integer_zero_node)),
7027                    gnu_expr);
7028
7029   /* GNU_RESULT has side effects if and only if GNU_EXPR has:
7030      we don't need to evaluate it just for the check.  */
7031   TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
7032
7033   return gnu_result;
7034 }
7035 \f
7036 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
7037    checks if OVERFLOW_P is true and range checks if RANGE_P is true.
7038    GNAT_TYPE is known to be an integral type.  If TRUNCATE_P true, do a
7039    float to integer conversion with truncation; otherwise round.
7040    GNAT_NODE is the GNAT node conveying the source location for which the
7041    error should be signaled.  */
7042
7043 static tree
7044 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
7045                     bool rangep, bool truncatep, Node_Id gnat_node)
7046 {
7047   tree gnu_type = get_unpadded_type (gnat_type);
7048   tree gnu_in_type = TREE_TYPE (gnu_expr);
7049   tree gnu_in_basetype = get_base_type (gnu_in_type);
7050   tree gnu_base_type = get_base_type (gnu_type);
7051   tree gnu_result = gnu_expr;
7052
7053   /* If we are not doing any checks, the output is an integral type, and
7054      the input is not a floating type, just do the conversion.  This
7055      shortcut is required to avoid problems with packed array types
7056      and simplifies code in all cases anyway.   */
7057   if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
7058       && !FLOAT_TYPE_P (gnu_in_type))
7059     return convert (gnu_type, gnu_expr);
7060
7061   /* First convert the expression to its base type.  This
7062      will never generate code, but makes the tests below much simpler.
7063      But don't do this if converting from an integer type to an unconstrained
7064      array type since then we need to get the bounds from the original
7065      (unpacked) type.  */
7066   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
7067     gnu_result = convert (gnu_in_basetype, gnu_result);
7068
7069   /* If overflow checks are requested,  we need to be sure the result will
7070      fit in the output base type.  But don't do this if the input
7071      is integer and the output floating-point.  */
7072   if (overflowp
7073       && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
7074     {
7075       /* Ensure GNU_EXPR only gets evaluated once.  */
7076       tree gnu_input = gnat_protect_expr (gnu_result);
7077       tree gnu_cond = integer_zero_node;
7078       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
7079       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
7080       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
7081       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
7082
7083       /* Convert the lower bounds to signed types, so we're sure we're
7084          comparing them properly.  Likewise, convert the upper bounds
7085          to unsigned types.  */
7086       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
7087         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
7088
7089       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7090           && !TYPE_UNSIGNED (gnu_in_basetype))
7091         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
7092
7093       if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
7094         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
7095
7096       if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
7097         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
7098
7099       /* Check each bound separately and only if the result bound
7100          is tighter than the bound on the input type.  Note that all the
7101          types are base types, so the bounds must be constant. Also,
7102          the comparison is done in the base type of the input, which
7103          always has the proper signedness.  First check for input
7104          integer (which means output integer), output float (which means
7105          both float), or mixed, in which case we always compare.
7106          Note that we have to do the comparison which would *fail* in the
7107          case of an error since if it's an FP comparison and one of the
7108          values is a NaN or Inf, the comparison will fail.  */
7109       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7110           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
7111           : (FLOAT_TYPE_P (gnu_base_type)
7112              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
7113                                  TREE_REAL_CST (gnu_out_lb))
7114              : 1))
7115         gnu_cond
7116           = invert_truthvalue
7117             (build_binary_op (GE_EXPR, boolean_type_node,
7118                               gnu_input, convert (gnu_in_basetype,
7119                                                   gnu_out_lb)));
7120
7121       if (INTEGRAL_TYPE_P (gnu_in_basetype)
7122           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
7123           : (FLOAT_TYPE_P (gnu_base_type)
7124              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
7125                                  TREE_REAL_CST (gnu_in_lb))
7126              : 1))
7127         gnu_cond
7128           = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
7129                              invert_truthvalue
7130                              (build_binary_op (LE_EXPR, boolean_type_node,
7131                                                gnu_input,
7132                                                convert (gnu_in_basetype,
7133                                                         gnu_out_ub))));
7134
7135       if (!integer_zerop (gnu_cond))
7136         gnu_result = emit_check (gnu_cond, gnu_input,
7137                                  CE_Overflow_Check_Failed, gnat_node);
7138     }
7139
7140   /* Now convert to the result base type.  If this is a non-truncating
7141      float-to-integer conversion, round.  */
7142   if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
7143       && !truncatep)
7144     {
7145       REAL_VALUE_TYPE half_minus_pred_half, pred_half;
7146       tree gnu_conv, gnu_zero, gnu_comp, calc_type;
7147       tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
7148       const struct real_format *fmt;
7149
7150       /* The following calculations depend on proper rounding to even
7151          of each arithmetic operation. In order to prevent excess
7152          precision from spoiling this property, use the widest hardware
7153          floating-point type if FP_ARITH_MAY_WIDEN is true.  */
7154       calc_type
7155         = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
7156
7157       /* FIXME: Should not have padding in the first place.  */
7158       if (TYPE_IS_PADDING_P (calc_type))
7159         calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
7160
7161       /* Compute the exact value calc_type'Pred (0.5) at compile time.  */
7162       fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
7163       real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
7164       REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
7165                        half_minus_pred_half);
7166       gnu_pred_half = build_real (calc_type, pred_half);
7167
7168       /* If the input is strictly negative, subtract this value
7169          and otherwise add it from the input.  For 0.5, the result
7170          is exactly between 1.0 and the machine number preceding 1.0
7171          (for calc_type).  Since the last bit of 1.0 is even, this 0.5
7172          will round to 1.0, while all other number with an absolute
7173          value less than 0.5 round to 0.0.  For larger numbers exactly
7174          halfway between integers, rounding will always be correct as
7175          the true mathematical result will be closer to the higher
7176          integer compared to the lower one.  So, this constant works
7177          for all floating-point numbers.
7178
7179          The reason to use the same constant with subtract/add instead
7180          of a positive and negative constant is to allow the comparison
7181          to be scheduled in parallel with retrieval of the constant and
7182          conversion of the input to the calc_type (if necessary).  */
7183
7184       gnu_zero = convert (gnu_in_basetype, integer_zero_node);
7185       gnu_result = gnat_protect_expr (gnu_result);
7186       gnu_conv = convert (calc_type, gnu_result);
7187       gnu_comp
7188         = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
7189       gnu_add_pred_half
7190         = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
7191       gnu_subtract_pred_half
7192         = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
7193       gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
7194                                 gnu_add_pred_half, gnu_subtract_pred_half);
7195     }
7196
7197   if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
7198       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
7199       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
7200     gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
7201   else
7202     gnu_result = convert (gnu_base_type, gnu_result);
7203
7204   /* Finally, do the range check if requested.  Note that if the result type
7205      is a modular type, the range check is actually an overflow check.  */
7206   if (rangep
7207       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
7208           && TYPE_MODULAR_P (gnu_base_type) && overflowp))
7209     gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
7210
7211   return convert (gnu_type, gnu_result);
7212 }
7213 \f
7214 /* Return true if TYPE is a smaller form of ORIG_TYPE.  */
7215
7216 static bool
7217 smaller_form_type_p (tree type, tree orig_type)
7218 {
7219   tree size, osize;
7220
7221   /* We're not interested in variants here.  */
7222   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (orig_type))
7223     return false;
7224
7225   /* Like a variant, a packable version keeps the original TYPE_NAME.  */
7226   if (TYPE_NAME (type) != TYPE_NAME (orig_type))
7227     return false;
7228
7229   size = TYPE_SIZE (type);
7230   osize = TYPE_SIZE (orig_type);
7231
7232   if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (osize) == INTEGER_CST))
7233     return false;
7234
7235   return tree_int_cst_lt (size, osize) != 0;
7236 }
7237
7238 /* Return true if GNU_EXPR can be directly addressed.  This is the case
7239    unless it is an expression involving computation or if it involves a
7240    reference to a bitfield or to an object not sufficiently aligned for
7241    its type.  If GNU_TYPE is non-null, return true only if GNU_EXPR can
7242    be directly addressed as an object of this type.
7243
7244    *** Notes on addressability issues in the Ada compiler ***
7245
7246    This predicate is necessary in order to bridge the gap between Gigi
7247    and the middle-end about addressability of GENERIC trees.  A tree
7248    is said to be addressable if it can be directly addressed, i.e. if
7249    its address can be taken, is a multiple of the type's alignment on
7250    strict-alignment architectures and returns the first storage unit
7251    assigned to the object represented by the tree.
7252
7253    In the C family of languages, everything is in practice addressable
7254    at the language level, except for bit-fields.  This means that these
7255    compilers will take the address of any tree that doesn't represent
7256    a bit-field reference and expect the result to be the first storage
7257    unit assigned to the object.  Even in cases where this will result
7258    in unaligned accesses at run time, nothing is supposed to be done
7259    and the program is considered as erroneous instead (see PR c/18287).
7260
7261    The implicit assumptions made in the middle-end are in keeping with
7262    the C viewpoint described above:
7263      - the address of a bit-field reference is supposed to be never
7264        taken; the compiler (generally) will stop on such a construct,
7265      - any other tree is addressable if it is formally addressable,
7266        i.e. if it is formally allowed to be the operand of ADDR_EXPR.
7267
7268    In Ada, the viewpoint is the opposite one: nothing is addressable
7269    at the language level unless explicitly declared so.  This means
7270    that the compiler will both make sure that the trees representing
7271    references to addressable ("aliased" in Ada parlance) objects are
7272    addressable and make no real attempts at ensuring that the trees
7273    representing references to non-addressable objects are addressable.
7274
7275    In the first case, Ada is effectively equivalent to C and handing
7276    down the direct result of applying ADDR_EXPR to these trees to the
7277    middle-end works flawlessly.  In the second case, Ada cannot afford
7278    to consider the program as erroneous if the address of trees that
7279    are not addressable is requested for technical reasons, unlike C;
7280    as a consequence, the Ada compiler must arrange for either making
7281    sure that this address is not requested in the middle-end or for
7282    compensating by inserting temporaries if it is requested in Gigi.
7283
7284    The first goal can be achieved because the middle-end should not
7285    request the address of non-addressable trees on its own; the only
7286    exception is for the invocation of low-level block operations like
7287    memcpy, for which the addressability requirements are lower since
7288    the type's alignment can be disregarded.  In practice, this means
7289    that Gigi must make sure that such operations cannot be applied to
7290    non-BLKmode bit-fields.
7291
7292    The second goal is achieved by means of the addressable_p predicate,
7293    which computes whether a temporary must be inserted by Gigi when the
7294    address of a tree is requested; if so, the address of the temporary
7295    will be used in lieu of that of the original tree and some glue code
7296    generated to connect everything together.  */
7297
7298 static bool
7299 addressable_p (tree gnu_expr, tree gnu_type)
7300 {
7301   /* For an integral type, the size of the actual type of the object may not
7302      be greater than that of the expected type, otherwise an indirect access
7303      in the latter type wouldn't correctly set all the bits of the object.  */
7304   if (gnu_type
7305       && INTEGRAL_TYPE_P (gnu_type)
7306       && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
7307     return false;
7308
7309   /* The size of the actual type of the object may not be smaller than that
7310      of the expected type, otherwise an indirect access in the latter type
7311      would be larger than the object.  But only record types need to be
7312      considered in practice for this case.  */
7313   if (gnu_type
7314       && TREE_CODE (gnu_type) == RECORD_TYPE
7315       && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
7316     return false;
7317
7318   switch (TREE_CODE (gnu_expr))
7319     {
7320     case VAR_DECL:
7321     case PARM_DECL:
7322     case FUNCTION_DECL:
7323     case RESULT_DECL:
7324       /* All DECLs are addressable: if they are in a register, we can force
7325          them to memory.  */
7326       return true;
7327
7328     case UNCONSTRAINED_ARRAY_REF:
7329     case INDIRECT_REF:
7330       /* Taking the address of a dereference yields the original pointer.  */
7331       return true;
7332
7333     case STRING_CST:
7334     case INTEGER_CST:
7335       /* Taking the address yields a pointer to the constant pool.  */
7336       return true;
7337
7338     case CONSTRUCTOR:
7339       /* Taking the address of a static constructor yields a pointer to the
7340          tree constant pool.  */
7341       return TREE_STATIC (gnu_expr) ? true : false;
7342
7343     case NULL_EXPR:
7344     case SAVE_EXPR:
7345     case CALL_EXPR:
7346     case PLUS_EXPR:
7347     case MINUS_EXPR:
7348     case BIT_IOR_EXPR:
7349     case BIT_XOR_EXPR:
7350     case BIT_AND_EXPR:
7351     case BIT_NOT_EXPR:
7352       /* All rvalues are deemed addressable since taking their address will
7353          force a temporary to be created by the middle-end.  */
7354       return true;
7355
7356     case COMPOUND_EXPR:
7357       /* The address of a compound expression is that of its 2nd operand.  */
7358       return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
7359
7360     case COND_EXPR:
7361       /* We accept &COND_EXPR as soon as both operands are addressable and
7362          expect the outcome to be the address of the selected operand.  */
7363       return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
7364               && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
7365
7366     case COMPONENT_REF:
7367       return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
7368                 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
7369                    the field is sufficiently aligned, in case it is subject
7370                    to a pragma Component_Alignment.  But we don't need to
7371                    check the alignment of the containing record, as it is
7372                    guaranteed to be not smaller than that of its most
7373                    aligned field that is not a bit-field.  */
7374                 && (!STRICT_ALIGNMENT
7375                     || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
7376                        >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
7377                /* The field of a padding record is always addressable.  */
7378                || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
7379               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7380
7381     case ARRAY_REF:  case ARRAY_RANGE_REF:
7382     case REALPART_EXPR:  case IMAGPART_EXPR:
7383     case NOP_EXPR:
7384       return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
7385
7386     case CONVERT_EXPR:
7387       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
7388               && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7389
7390     case VIEW_CONVERT_EXPR:
7391       {
7392         /* This is addressable if we can avoid a copy.  */
7393         tree type = TREE_TYPE (gnu_expr);
7394         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
7395         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
7396                   && (!STRICT_ALIGNMENT
7397                       || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7398                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
7399                  || ((TYPE_MODE (type) == BLKmode
7400                       || TYPE_MODE (inner_type) == BLKmode)
7401                      && (!STRICT_ALIGNMENT
7402                          || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7403                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
7404                          || TYPE_ALIGN_OK (type)
7405                          || TYPE_ALIGN_OK (inner_type))))
7406                 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7407       }
7408
7409     default:
7410       return false;
7411     }
7412 }
7413 \f
7414 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
7415    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
7416    make a GCC type for GNAT_ENTITY and set up the correspondence.  */
7417
7418 void
7419 process_type (Entity_Id gnat_entity)
7420 {
7421   tree gnu_old
7422     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
7423   tree gnu_new;
7424
7425   /* If we are to delay elaboration of this type, just do any
7426      elaborations needed for expressions within the declaration and
7427      make a dummy type entry for this node and its Full_View (if
7428      any) in case something points to it.  Don't do this if it
7429      has already been done (the only way that can happen is if
7430      the private completion is also delayed).  */
7431   if (Present (Freeze_Node (gnat_entity))
7432       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7433           && Present (Full_View (gnat_entity))
7434           && Freeze_Node (Full_View (gnat_entity))
7435           && !present_gnu_tree (Full_View (gnat_entity))))
7436     {
7437       elaborate_entity (gnat_entity);
7438
7439       if (!gnu_old)
7440         {
7441           tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
7442           save_gnu_tree (gnat_entity, gnu_decl, false);
7443           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7444               && Present (Full_View (gnat_entity)))
7445             save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
7446         }
7447
7448       return;
7449     }
7450
7451   /* If we saved away a dummy type for this node it means that this
7452      made the type that corresponds to the full type of an incomplete
7453      type.  Clear that type for now and then update the type in the
7454      pointers.  */
7455   if (gnu_old)
7456     {
7457       gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
7458                   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
7459
7460       save_gnu_tree (gnat_entity, NULL_TREE, false);
7461     }
7462
7463   /* Now fully elaborate the type.  */
7464   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
7465   gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
7466
7467   /* If we have an old type and we've made pointers to this type,
7468      update those pointers.  */
7469   if (gnu_old)
7470     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
7471                        TREE_TYPE (gnu_new));
7472
7473   /* If this is a record type corresponding to a task or protected type
7474      that is a completion of an incomplete type, perform a similar update
7475      on the type.  ??? Including protected types here is a guess.  */
7476   if (IN (Ekind (gnat_entity), Record_Kind)
7477       && Is_Concurrent_Record_Type (gnat_entity)
7478       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
7479     {
7480       tree gnu_task_old
7481         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
7482
7483       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7484                      NULL_TREE, false);
7485       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7486                      gnu_new, false);
7487
7488       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
7489                          TREE_TYPE (gnu_new));
7490     }
7491 }
7492 \f
7493 /* GNAT_ENTITY is the type of the resulting constructors,
7494    GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
7495    and GNU_TYPE is the GCC type of the corresponding record.
7496
7497    Return a CONSTRUCTOR to build the record.  */
7498
7499 static tree
7500 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
7501 {
7502   tree gnu_list, gnu_result;
7503
7504   /* We test for GNU_FIELD being empty in the case where a variant
7505      was the last thing since we don't take things off GNAT_ASSOC in
7506      that case.  We check GNAT_ASSOC in case we have a variant, but it
7507      has no fields.  */
7508
7509   for (gnu_list = NULL_TREE; Present (gnat_assoc);
7510        gnat_assoc = Next (gnat_assoc))
7511     {
7512       Node_Id gnat_field = First (Choices (gnat_assoc));
7513       tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
7514       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
7515
7516       /* The expander is supposed to put a single component selector name
7517          in every record component association.  */
7518       gcc_assert (No (Next (gnat_field)));
7519
7520       /* Ignore fields that have Corresponding_Discriminants since we'll
7521          be setting that field in the parent.  */
7522       if (Present (Corresponding_Discriminant (Entity (gnat_field)))
7523           && Is_Tagged_Type (Scope (Entity (gnat_field))))
7524         continue;
7525
7526       /* Also ignore discriminants of Unchecked_Unions.  */
7527       else if (Is_Unchecked_Union (gnat_entity)
7528                && Ekind (Entity (gnat_field)) == E_Discriminant)
7529         continue;
7530
7531       /* Before assigning a value in an aggregate make sure range checks
7532          are done if required.  Then convert to the type of the field.  */
7533       if (Do_Range_Check (Expression (gnat_assoc)))
7534         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
7535
7536       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
7537
7538       /* Add the field and expression to the list.  */
7539       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
7540     }
7541
7542   gnu_result = extract_values (gnu_list, gnu_type);
7543
7544 #ifdef ENABLE_CHECKING
7545   {
7546     tree gnu_field;
7547
7548     /* Verify every entry in GNU_LIST was used.  */
7549     for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
7550       gcc_assert (TREE_ADDRESSABLE (gnu_field));
7551   }
7552 #endif
7553
7554   return gnu_result;
7555 }
7556
7557 /* Build a possibly nested constructor for array aggregates.  GNAT_EXPR is
7558    the first element of an array aggregate.  It may itself be an aggregate.
7559    GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
7560    GNAT_COMPONENT_TYPE is the type of the array component; it is needed
7561    for range checking.  */
7562
7563 static tree
7564 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
7565                     Entity_Id gnat_component_type)
7566 {
7567   tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
7568   tree gnu_expr;
7569   VEC(constructor_elt,gc) *gnu_expr_vec = NULL;
7570
7571   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
7572     {
7573       /* If the expression is itself an array aggregate then first build the
7574          innermost constructor if it is part of our array (multi-dimensional
7575          case).  */
7576       if (Nkind (gnat_expr) == N_Aggregate
7577           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
7578           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
7579         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
7580                                        TREE_TYPE (gnu_array_type),
7581                                        gnat_component_type);
7582       else
7583         {
7584           gnu_expr = gnat_to_gnu (gnat_expr);
7585
7586           /* Before assigning the element to the array, make sure it is
7587              in range.  */
7588           if (Do_Range_Check (gnat_expr))
7589             gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
7590         }
7591
7592       CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
7593                               convert (TREE_TYPE (gnu_array_type), gnu_expr));
7594
7595       gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
7596     }
7597
7598   return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
7599 }
7600 \f
7601 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
7602    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
7603    of the associations that are from RECORD_TYPE.  If we see an internal
7604    record, make a recursive call to fill it in as well.  */
7605
7606 static tree
7607 extract_values (tree values, tree record_type)
7608 {
7609   tree field, tem;
7610   VEC(constructor_elt,gc) *v = NULL;
7611
7612   for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
7613     {
7614       tree value = 0;
7615
7616       /* _Parent is an internal field, but may have values in the aggregate,
7617          so check for values first.  */
7618       if ((tem = purpose_member (field, values)))
7619         {
7620           value = TREE_VALUE (tem);
7621           TREE_ADDRESSABLE (tem) = 1;
7622         }
7623
7624       else if (DECL_INTERNAL_P (field))
7625         {
7626           value = extract_values (values, TREE_TYPE (field));
7627           if (TREE_CODE (value) == CONSTRUCTOR
7628               && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
7629             value = 0;
7630         }
7631       else
7632         /* If we have a record subtype, the names will match, but not the
7633            actual FIELD_DECLs.  */
7634         for (tem = values; tem; tem = TREE_CHAIN (tem))
7635           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
7636             {
7637               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
7638               TREE_ADDRESSABLE (tem) = 1;
7639             }
7640
7641       if (!value)
7642         continue;
7643
7644       CONSTRUCTOR_APPEND_ELT (v, field, value);
7645     }
7646
7647   return gnat_build_constructor (record_type, v);
7648 }
7649 \f
7650 /* EXP is to be treated as an array or record.  Handle the cases when it is
7651    an access object and perform the required dereferences.  */
7652
7653 static tree
7654 maybe_implicit_deref (tree exp)
7655 {
7656   /* If the type is a pointer, dereference it.  */
7657   if (POINTER_TYPE_P (TREE_TYPE (exp))
7658       || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
7659     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
7660
7661   /* If we got a padded type, remove it too.  */
7662   if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
7663     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
7664
7665   return exp;
7666 }
7667 \f
7668 /* Convert SLOC into LOCUS.  Return true if SLOC corresponds to a source code
7669    location and false if it doesn't.  In the former case, set the Gigi global
7670    variable REF_FILENAME to the simple debug file name as given by sinput.  */
7671
7672 bool
7673 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
7674 {
7675   if (Sloc == No_Location)
7676     return false;
7677
7678   if (Sloc <= Standard_Location)
7679     {
7680       *locus = BUILTINS_LOCATION;
7681       return false;
7682     }
7683   else
7684     {
7685       Source_File_Index file = Get_Source_File_Index (Sloc);
7686       Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
7687       Column_Number column = Get_Column_Number (Sloc);
7688       struct line_map *map = &line_table->maps[file - 1];
7689
7690       /* Translate the location according to the line-map.h formula.  */
7691       *locus = map->start_location
7692                 + ((line - map->to_line) << map->column_bits)
7693                 + (column & ((1 << map->column_bits) - 1));
7694     }
7695
7696   ref_filename
7697     = IDENTIFIER_POINTER
7698       (get_identifier
7699        (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
7700
7701   return true;
7702 }
7703
7704 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
7705    don't do anything if it doesn't correspond to a source location.  */
7706
7707 static void
7708 set_expr_location_from_node (tree node, Node_Id gnat_node)
7709 {
7710   location_t locus;
7711
7712   if (!Sloc_to_locus (Sloc (gnat_node), &locus))
7713     return;
7714
7715   SET_EXPR_LOCATION (node, locus);
7716 }
7717
7718 /* More elaborate version of set_expr_location_from_node to be used in more
7719    general contexts, for example the result of the translation of a generic
7720    GNAT node.  */
7721
7722 static void
7723 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
7724 {
7725   /* Set the location information on the node if it is a real expression.
7726      References can be reused for multiple GNAT nodes and they would get
7727      the location information of their last use.  Also make sure not to
7728      overwrite an existing location as it is probably more precise.  */
7729
7730   switch (TREE_CODE (node))
7731     {
7732     CASE_CONVERT:
7733     case NON_LVALUE_EXPR:
7734       break;
7735
7736     case COMPOUND_EXPR:
7737       if (EXPR_P (TREE_OPERAND (node, 1)))
7738         set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
7739
7740       /* ... fall through ... */
7741
7742     default:
7743       if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
7744         set_expr_location_from_node (node, gnat_node);
7745       break;
7746     }
7747 }
7748 \f
7749 /* Return a colon-separated list of encodings contained in encoded Ada
7750    name.  */
7751
7752 static const char *
7753 extract_encoding (const char *name)
7754 {
7755   char *encoding = (char *) ggc_alloc_atomic (strlen (name));
7756   get_encoding (name, encoding);
7757   return encoding;
7758 }
7759
7760 /* Extract the Ada name from an encoded name.  */
7761
7762 static const char *
7763 decode_name (const char *name)
7764 {
7765   char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
7766   __gnat_decode (name, decoded, 0);
7767   return decoded;
7768 }
7769 \f
7770 /* Post an error message.  MSG is the error message, properly annotated.
7771    NODE is the node at which to post the error and the node to use for the
7772    '&' substitution.  */
7773
7774 void
7775 post_error (const char *msg, Node_Id node)
7776 {
7777   String_Template temp;
7778   Fat_Pointer fp;
7779
7780   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7781   fp.Array = msg, fp.Bounds = &temp;
7782   if (Present (node))
7783     Error_Msg_N (fp, node);
7784 }
7785
7786 /* Similar to post_error, but NODE is the node at which to post the error and
7787    ENT is the node to use for the '&' substitution.  */
7788
7789 void
7790 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
7791 {
7792   String_Template temp;
7793   Fat_Pointer fp;
7794
7795   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7796   fp.Array = msg, fp.Bounds = &temp;
7797   if (Present (node))
7798     Error_Msg_NE (fp, node, ent);
7799 }
7800
7801 /* Similar to post_error_ne, but NUM is the number to use for the '^'.  */
7802
7803 void
7804 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
7805 {
7806   Error_Msg_Uint_1 = UI_From_Int (num);
7807   post_error_ne (msg, node, ent);
7808 }
7809 \f
7810 /* Similar to post_error_ne, but T is a GCC tree representing the number to
7811    write.  If T represents a constant, the text inside curly brackets in
7812    MSG will be output (presumably including a '^').  Otherwise it will not
7813    be output and the text inside square brackets will be output instead.  */
7814
7815 void
7816 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
7817 {
7818   char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
7819   char start_yes, end_yes, start_no, end_no;
7820   const char *p;
7821   char *q;
7822
7823   if (TREE_CODE (t) == INTEGER_CST)
7824     {
7825       Error_Msg_Uint_1 = UI_From_gnu (t);
7826       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
7827     }
7828   else
7829     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
7830
7831   for (p = msg, q = new_msg; *p; p++)
7832     {
7833       if (*p == start_yes)
7834         for (p++; *p != end_yes; p++)
7835           *q++ = *p;
7836       else if (*p == start_no)
7837         for (p++; *p != end_no; p++)
7838           ;
7839       else
7840         *q++ = *p;
7841     }
7842
7843   *q = 0;
7844
7845   post_error_ne (new_msg, node, ent);
7846 }
7847
7848 /* Similar to post_error_ne_tree, but NUM is a second integer to write.  */
7849
7850 void
7851 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
7852                       int num)
7853 {
7854   Error_Msg_Uint_2 = UI_From_Int (num);
7855   post_error_ne_tree (msg, node, ent, t);
7856 }
7857 \f
7858 /* Initialize the table that maps GNAT codes to GCC codes for simple
7859    binary and unary operations.  */
7860
7861 static void
7862 init_code_table (void)
7863 {
7864   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
7865   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
7866
7867   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
7868   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
7869   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
7870   gnu_codes[N_Op_Eq] = EQ_EXPR;
7871   gnu_codes[N_Op_Ne] = NE_EXPR;
7872   gnu_codes[N_Op_Lt] = LT_EXPR;
7873   gnu_codes[N_Op_Le] = LE_EXPR;
7874   gnu_codes[N_Op_Gt] = GT_EXPR;
7875   gnu_codes[N_Op_Ge] = GE_EXPR;
7876   gnu_codes[N_Op_Add] = PLUS_EXPR;
7877   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
7878   gnu_codes[N_Op_Multiply] = MULT_EXPR;
7879   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
7880   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
7881   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
7882   gnu_codes[N_Op_Abs] = ABS_EXPR;
7883   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
7884   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
7885   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
7886   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
7887   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
7888   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
7889 }
7890
7891 /* Return a label to branch to for the exception type in KIND or NULL_TREE
7892    if none.  */
7893
7894 tree
7895 get_exception_label (char kind)
7896 {
7897   if (kind == N_Raise_Constraint_Error)
7898     return VEC_last (tree, gnu_constraint_error_label_stack);
7899   else if (kind == N_Raise_Storage_Error)
7900     return VEC_last (tree, gnu_storage_error_label_stack);
7901   else if (kind == N_Raise_Program_Error)
7902     return VEC_last (tree, gnu_program_error_label_stack);
7903   else
7904     return NULL_TREE;
7905 }
7906
7907 /* Return the decl for the current elaboration procedure.  */
7908
7909 tree
7910 get_elaboration_procedure (void)
7911 {
7912   return VEC_last (tree, gnu_elab_proc_stack);
7913 }
7914
7915 #include "gt-ada-trans.h"