gcc/ada/gcc-interface/trans.c

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