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