gcc/ada/gcc-interface/trans.c

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