gcc/ada/gcc-interface/trans.c

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