gcc/ada/gcc-interface/trans.c

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