gcc/ada/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-2006, 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 2,  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 COPYING.  If not, write *
  19  * to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, *
  20  * Boston, MA 02110-1301, USA.                                              *
  21  *                                                                          *
  22  * GNAT was originally developed  by the GNAT team at  New York University. *
  23  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  24  *                                                                          *
  25  ****************************************************************************/
  26
  27 #include "config.h"
  28 #include "system.h"
  29 #include "coretypes.h"
  30 #include "tm.h"
  31 #include "tree.h"
  32 #include "real.h"
  33 #include "flags.h"
  34 #include "toplev.h"
  35 #include "rtl.h"
  36 #include "expr.h"
  37 #include "ggc.h"
  38 #include "cgraph.h"
  39 #include "function.h"
  40 #include "except.h"
  41 #include "debug.h"
  42 #include "output.h"
  43 #include "tree-gimple.h"
  44 #include "ada.h"
  45 #include "types.h"
  46 #include "atree.h"
  47 #include "elists.h"
  48 #include "namet.h"
  49 #include "nlists.h"
  50 #include "snames.h"
  51 #include "stringt.h"
  52 #include "uintp.h"
  53 #include "urealp.h"
  54 #include "fe.h"
  55 #include "sinfo.h"
  56 #include "einfo.h"
  57 #include "ada-tree.h"
  58 #include "gigi.h"
  59
  60 /* Let code below know whether we are targetting VMS without need of
  61    intrusive preprocessor directives.  */
  62 #ifndef TARGET_ABI_OPEN_VMS
  63 #define TARGET_ABI_OPEN_VMS 0
  64 #endif
  65
  66 int max_gnat_nodes;
  67 int number_names;
  68 struct Node *Nodes_Ptr;
  69 Node_Id *Next_Node_Ptr;
  70 Node_Id *Prev_Node_Ptr;
  71 struct Elist_Header *Elists_Ptr;
  72 struct Elmt_Item *Elmts_Ptr;
  73 struct String_Entry *Strings_Ptr;
  74 Char_Code *String_Chars_Ptr;
  75 struct List_Header *List_Headers_Ptr;
  76
  77 /* Current filename without path. */
  78 const char *ref_filename;
  79
  80 /* If true, then gigi is being called on an analyzed but unexpanded
  81    tree, and the only purpose of the call is to properly annotate
  82    types with representation information. */
  83 bool type_annotate_only;
  84
  85 /* A structure used to gather together information about a statement group.
  86    We use this to gather related statements, for example the "then" part
  87    of a IF.  In the case where it represents a lexical scope, we may also
  88    have a BLOCK node corresponding to it and/or cleanups.  */
  89
  90 struct stmt_group GTY((chain_next ("%h.previous"))) {
  91   struct stmt_group *previous;  /* Previous code group.  */
  92   tree stmt_list;               /* List of statements for this code group. */
  93   tree block;                   /* BLOCK for this code group, if any. */
  94   tree cleanups;                /* Cleanups for this code group, if any.  */
  95 };
  96
  97 static GTY(()) struct stmt_group *current_stmt_group;
  98
  99 /* List of unused struct stmt_group nodes.  */
 100 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
 101
 102 /* A structure used to record information on elaboration procedures
 103    we've made and need to process.
 104
 105    ??? gnat_node should be Node_Id, but gengtype gets confused.  */
 106
 107 struct elab_info GTY((chain_next ("%h.next"))) {
 108   struct elab_info *next;       /* Pointer to next in chain. */
 109   tree elab_proc;               /* Elaboration procedure.  */
 110   int gnat_node;                /* The N_Compilation_Unit.  */
 111 };
 112
 113 static GTY(()) struct elab_info *elab_info_list;
 114
 115 /* Free list of TREE_LIST nodes used for stacks.  */
 116 static GTY((deletable)) tree gnu_stack_free_list;
 117
 118 /* List of TREE_LIST nodes representing a stack of exception pointer
 119    variables.  TREE_VALUE is the VAR_DECL that stores the address of
 120    the raised exception.  Nonzero means we are in an exception
 121    handler.  Not used in the zero-cost case.  */
 122 static GTY(()) tree gnu_except_ptr_stack;
 123
 124 /* List of TREE_LIST nodes used to store the current elaboration procedure
 125    decl.  TREE_VALUE is the decl.  */
 126 static GTY(()) tree gnu_elab_proc_stack;
 127
 128 /* Variable that stores a list of labels to be used as a goto target instead of
 129    a return in some functions.  See processing for N_Subprogram_Body.  */
 130 static GTY(()) tree gnu_return_label_stack;
 131
 132 /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes.
 133    TREE_VALUE of each entry is the label of the corresponding LOOP_STMT.  */
 134 static GTY(()) tree gnu_loop_label_stack;
 135
 136 /* List of TREE_LIST nodes representing labels for switch statements.
 137    TREE_VALUE of each entry is the label at the end of the switch.  */
 138 static GTY(()) tree gnu_switch_label_stack;
 139
 140 /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
 141 static enum tree_code gnu_codes[Number_Node_Kinds];
 142
 143 /* Current node being treated, in case abort called.  */
 144 Node_Id error_gnat_node;
 145
 146 static void Compilation_Unit_to_gnu (Node_Id);
 147 static void record_code_position (Node_Id);
 148 static void insert_code_for (Node_Id);
 149 static void start_stmt_group (void);
 150 static void add_cleanup (tree);
 151 static tree mark_visited (tree *, int *, void *);
 152 static tree mark_unvisited (tree *, int *, void *);
 153 static tree end_stmt_group (void);
 154 static void add_stmt_list (List_Id);
 155 static tree build_stmt_group (List_Id, bool);
 156 static void push_stack (tree *, tree, tree);
 157 static void pop_stack (tree *);
 158 static enum gimplify_status gnat_gimplify_stmt (tree *);
 159 static void elaborate_all_entities (Node_Id);
 160 static void process_freeze_entity (Node_Id);
 161 static void process_inlined_subprograms (Node_Id);
 162 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
 163 static tree emit_range_check (tree, Node_Id);
 164 static tree emit_index_check (tree, tree, tree, tree);
 165 static tree emit_check (tree, tree, int);
 166 static tree convert_with_check (Entity_Id, tree, bool, bool, bool);
 167 static bool addressable_p (tree);
 168 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 169 static tree extract_values (tree, tree);
 170 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
 171 static tree maybe_implicit_deref (tree);
 172 static tree gnat_stabilize_reference_1 (tree, bool);
 173 static void annotate_with_node (tree, Node_Id);
 174 static void build_global_cdtor (int, tree *);
 175
 176 \f
 177 /* This is the main program of the back-end.  It sets up all the table
 178    structures and then generates code.  */
 179
 180 void
 181 gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
 182       struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
 183       struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
 184       struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
 185       struct List_Header *list_headers_ptr, Int number_units ATTRIBUTE_UNUSED,
 186       char *file_info_ptr ATTRIBUTE_UNUSED, Entity_Id standard_integer,
 187       Entity_Id standard_long_long_float, Entity_Id standard_exception_type,
 188       Int gigi_operating_mode)
 189 {
 190   tree gnu_standard_long_long_float;
 191   tree gnu_standard_exception_type;
 192   struct elab_info *info;
 193
 194   max_gnat_nodes = max_gnat_node;
 195   number_names = number_name;
 196   Nodes_Ptr = nodes_ptr;
 197   Next_Node_Ptr = next_node_ptr;
 198   Prev_Node_Ptr = prev_node_ptr;
 199   Elists_Ptr = elists_ptr;
 200   Elmts_Ptr = elmts_ptr;
 201   Strings_Ptr = strings_ptr;
 202   String_Chars_Ptr = string_chars_ptr;
 203   List_Headers_Ptr = list_headers_ptr;
 204
 205   type_annotate_only = (gigi_operating_mode == 1);
 206
 207   init_gnat_to_gnu ();
 208   gnat_compute_largest_alignment ();
 209   init_dummy_type ();
 210
 211   /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
 212      errors.  */
 213   if (type_annotate_only)
 214     {
 215       TYPE_SIZE (void_type_node) = bitsize_zero_node;
 216       TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
 217     }
 218
 219   /* Save the type we made for integer as the type for Standard.Integer.
 220      Then make the rest of the standard types.  Note that some of these
 221      may be subtypes.  */
 222   save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node),
 223                  false);
 224
 225   gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 226
 227   gnu_standard_long_long_float
 228     = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
 229   gnu_standard_exception_type
 230     = gnat_to_gnu_entity (Base_Type (standard_exception_type),  NULL_TREE, 0);
 231
 232   init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type);
 233
 234   /* Process any Pragma Ident for the main unit.  */
 235 #ifdef ASM_OUTPUT_IDENT
 236   if (Present (Ident_String (Main_Unit)))
 237     ASM_OUTPUT_IDENT
 238       (asm_out_file,
 239        TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
 240 #endif
 241
 242   /* If we are using the GCC exception mechanism, let GCC know.  */
 243   if (Exception_Mechanism == Back_End_Exceptions)
 244     gnat_init_gcc_eh ();
 245
 246   gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
 247   Compilation_Unit_to_gnu (gnat_root);
 248
 249   /* Now see if we have any elaboration procedures to deal with. */
 250   for (info = elab_info_list; info; info = info->next)
 251     {
 252       tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
 253       tree gnu_stmts;
 254
 255       /* Mark everything we have as not visited.  */
 256       walk_tree_without_duplicates (&gnu_body, mark_unvisited, NULL);
 257
 258       /* Set the current function to be the elaboration procedure and gimplify
 259          what we have.  */
 260       current_function_decl = info->elab_proc;
 261       gimplify_body (&gnu_body, info->elab_proc, true);
 262
 263       /* We should have a BIND_EXPR, but it may or may not have any statements
 264          in it.  If it doesn't have any, we have nothing to do.  */
 265       gnu_stmts = gnu_body;
 266       if (TREE_CODE (gnu_stmts) == BIND_EXPR)
 267         gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
 268
 269       /* If there are no statements, there is no elaboration code.  */
 270       if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
 271         Set_Has_No_Elaboration_Code (info->gnat_node, 1);
 272       else
 273         {
 274           /* Otherwise, compile the function.  Note that we'll be gimplifying
 275              it twice, but that's fine for the nodes we use.  */
 276           begin_subprog_body (info->elab_proc);
 277           end_subprog_body (gnu_body);
 278         }
 279     }
 280 }
 281 \f
 282 /* Perform initializations for this module.  */
 283
 284 void
 285 gnat_init_stmt_group ()
 286 {
 287   /* Initialize ourselves.  */
 288   init_code_table ();
 289   start_stmt_group ();
 290
 291   /* Enable GNAT stack checking method if needed */
 292   if (!Stack_Check_Probes_On_Target)
 293     set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
 294 }
 295 \f
 296 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
 297    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
 298    where we should place the result type.  */
 299
 300 static tree
 301 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 302 {
 303   tree gnu_result_type;
 304   tree gnu_result;
 305   Node_Id gnat_temp, gnat_temp_type;
 306
 307   /* If the Etype of this node does not equal the Etype of the Entity,
 308      something is wrong with the entity map, probably in generic
 309      instantiation. However, this does not apply to types. Since we sometime
 310      have strange Ekind's, just do this test for objects. Also, if the Etype of
 311      the Entity is private, the Etype of the N_Identifier is allowed to be the
 312      full type and also we consider a packed array type to be the same as the
 313      original type. Similarly, a class-wide type is equivalent to a subtype of
 314      itself. Finally, if the types are Itypes, one may be a copy of the other,
 315      which is also legal.  */
 316   gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
 317                ? gnat_node : Entity (gnat_node));
 318   gnat_temp_type = Etype (gnat_temp);
 319
 320   gcc_assert (Etype (gnat_node) == gnat_temp_type
 321               || (Is_Packed (gnat_temp_type)
 322                   && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
 323               || (Is_Class_Wide_Type (Etype (gnat_node)))
 324               || (IN (Ekind (gnat_temp_type), Private_Kind)
 325                   && Present (Full_View (gnat_temp_type))
 326                   && ((Etype (gnat_node) == Full_View (gnat_temp_type))
 327                       || (Is_Packed (Full_View (gnat_temp_type))
 328                           && (Etype (gnat_node)
 329                               == Packed_Array_Type (Full_View
 330                                                     (gnat_temp_type))))))
 331               || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
 332               || !(Ekind (gnat_temp) == E_Variable
 333                    || Ekind (gnat_temp) == E_Component
 334                    || Ekind (gnat_temp) == E_Constant
 335                    || Ekind (gnat_temp) == E_Loop_Parameter
 336                    || IN (Ekind (gnat_temp), Formal_Kind)));
 337
 338   /* If this is a reference to a deferred constant whose partial view is an
 339      unconstrained private type, the proper type is on the full view of the
 340      constant, not on the full view of the type, which may be unconstrained.
 341
 342      This may be a reference to a type, for example in the prefix of the
 343      attribute Position, generated for dispatching code (see Make_DT in
 344      exp_disp,adb). In that case we need the type itself, not is parent,
 345      in particular if it is a derived type  */
 346   if (Is_Private_Type (gnat_temp_type)
 347       && Has_Unknown_Discriminants (gnat_temp_type)
 348       && Present (Full_View (gnat_temp))
 349       && !Is_Type (gnat_temp))
 350     {
 351       gnat_temp = Full_View (gnat_temp);
 352       gnat_temp_type = Etype (gnat_temp);
 353       gnu_result_type = get_unpadded_type (gnat_temp_type);
 354     }
 355   else
 356     {
 357       /* Expand the type of this identifier first, in case it is an enumeral
 358          literal, which only get made when the type is expanded.  There is no
 359          order-of-elaboration issue here.  We want to use the Actual_Subtype if
 360          it has already been elaborated, otherwise the Etype.  Avoid using
 361          Actual_Subtype for packed arrays to simplify things.  */
 362       if ((Ekind (gnat_temp) == E_Constant
 363            || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
 364           && !(Is_Array_Type (Etype (gnat_temp))
 365                && Present (Packed_Array_Type (Etype (gnat_temp))))
 366           && Present (Actual_Subtype (gnat_temp))
 367           && present_gnu_tree (Actual_Subtype (gnat_temp)))
 368         gnat_temp_type = Actual_Subtype (gnat_temp);
 369       else
 370         gnat_temp_type = Etype (gnat_node);
 371
 372       gnu_result_type = get_unpadded_type (gnat_temp_type);
 373     }
 374
 375   gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
 376
 377   /* If we are in an exception handler, force this variable into memory to
 378      ensure optimization does not remove stores that appear redundant but are
 379      actually needed in case an exception occurs.
 380
 381      ??? Note that we need not do this if the variable is declared within the
 382      handler, only if it is referenced in the handler and declared in an
 383      enclosing block, but we have no way of testing that right now.
 384
 385      ??? Also, for now all we can do is make it volatile.  But we only
 386      do this for SJLJ.  */
 387   if (TREE_VALUE (gnu_except_ptr_stack)
 388       && TREE_CODE (gnu_result) == VAR_DECL)
 389     TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
 390
 391   /* Some objects (such as parameters passed by reference, globals of
 392      variable size, and renamed objects) actually represent the address
 393      of the object.  In that case, we must do the dereference.  Likewise,
 394      deal with parameters to foreign convention subprograms.  Call fold
 395      here since GNU_RESULT may be a CONST_DECL.  */
 396   if (DECL_P (gnu_result)
 397       && (DECL_BY_REF_P (gnu_result)
 398           || (TREE_CODE (gnu_result) == PARM_DECL
 399               && DECL_BY_COMPONENT_PTR_P (gnu_result))))
 400     {
 401       bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
 402       tree renamed_obj;
 403
 404       if (TREE_CODE (gnu_result) == PARM_DECL
 405           && DECL_BY_COMPONENT_PTR_P (gnu_result))
 406         gnu_result
 407           = build_unary_op (INDIRECT_REF, NULL_TREE,
 408                             convert (build_pointer_type (gnu_result_type),
 409                                      gnu_result));
 410
 411       /* If it's a renaming pointer and we are at the right binding level,
 412          we can reference the renamed object directly, since the renamed
 413          expression has been protected against multiple evaluations.  */
 414       else if (TREE_CODE (gnu_result) == VAR_DECL
 415                && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0
 416                && (! DECL_RENAMING_GLOBAL_P (gnu_result)
 417                    || global_bindings_p ()))
 418         gnu_result = renamed_obj;
 419       else
 420         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
 421                                      fold (gnu_result));
 422
 423       TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
 424     }
 425
 426   /* The GNAT tree has the type of a function as the type of its result.  Also
 427      use the type of the result if the Etype is a subtype which is nominally
 428      unconstrained.  But remove any padding from the resulting type.  */
 429   if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
 430       || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
 431     {
 432       gnu_result_type = TREE_TYPE (gnu_result);
 433       if (TREE_CODE (gnu_result_type) == RECORD_TYPE
 434           && TYPE_IS_PADDING_P (gnu_result_type))
 435         gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
 436     }
 437
 438   /* We always want to return the underlying INTEGER_CST for an enumeration
 439      literal to avoid the need to call fold in lots of places.  But don't do
 440      this is the parent will be taking the address of this object.  */
 441   if (TREE_CODE (gnu_result) == CONST_DECL)
 442     {
 443       gnat_temp = Parent (gnat_node);
 444       if (!DECL_CONST_CORRESPONDING_VAR (gnu_result)
 445           || (Nkind (gnat_temp) != N_Reference
 446               && !(Nkind (gnat_temp) == N_Attribute_Reference
 447                    && ((Get_Attribute_Id (Attribute_Name (gnat_temp))
 448                         == Attr_Address)
 449                        || (Get_Attribute_Id (Attribute_Name (gnat_temp))
 450                            == Attr_Access)
 451                        || (Get_Attribute_Id (Attribute_Name (gnat_temp))
 452                             == Attr_Unchecked_Access)
 453                        || (Get_Attribute_Id (Attribute_Name (gnat_temp))
 454                            == Attr_Unrestricted_Access)))))
 455         {
 456           gnu_result = DECL_INITIAL (gnu_result);
 457           /* ??? The mark/unmark mechanism implemented in Gigi to prevent tree
 458              sharing between global level and subprogram level doesn't apply
 459              to elaboration routines.  As a result, the DECL_INITIAL tree may
 460              be shared between the static initializer of a global object and
 461              the elaboration routine, thus wreaking havoc if a local temporary
 462              is created in place during gimplification of the latter and the
 463              former is emitted afterwards.  Manually unshare for now.  */
 464           if (TREE_VISITED (gnu_result))
 465             gnu_result = unshare_expr (gnu_result);
 466         }
 467     }
 468
 469   *gnu_result_type_p = gnu_result_type;
 470   return gnu_result;
 471 }
 472 \f
 473 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
 474    any statements we generate.  */
 475
 476 static tree
 477 Pragma_to_gnu (Node_Id gnat_node)
 478 {
 479   Node_Id gnat_temp;
 480   tree gnu_result = alloc_stmt_list ();
 481
 482   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
 483      annotating types.  */
 484   if (type_annotate_only || !Is_Pragma_Name (Chars (gnat_node)))
 485     return gnu_result;
 486
 487   switch (Get_Pragma_Id (Chars (gnat_node)))
 488     {
 489     case Pragma_Inspection_Point:
 490       /* Do nothing at top level: all such variables are already viewable.  */
 491       if (global_bindings_p ())
 492         break;
 493
 494       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
 495            Present (gnat_temp);
 496            gnat_temp = Next (gnat_temp))
 497         {
 498           tree gnu_expr = gnat_to_gnu (Expression (gnat_temp));
 499
 500           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
 501             gnu_expr = TREE_OPERAND (gnu_expr, 0);
 502
 503           gnu_expr = build1 (USE_STMT, void_type_node, gnu_expr);
 504           annotate_with_node (gnu_expr, gnat_node);
 505           append_to_statement_list (gnu_expr, &gnu_result);
 506         }
 507       break;
 508
 509     case Pragma_Optimize:
 510       switch (Chars (Expression
 511                      (First (Pragma_Argument_Associations (gnat_node)))))
 512         {
 513         case Name_Time:  case Name_Space:
 514           if (optimize == 0)
 515             post_error ("insufficient -O value?", gnat_node);
 516           break;
 517
 518         case Name_Off:
 519           if (optimize != 0)
 520             post_error ("must specify -O0?", gnat_node);
 521           break;
 522
 523         default:
 524           gcc_unreachable ();
 525         }
 526       break;
 527
 528     case Pragma_Reviewable:
 529       if (write_symbols == NO_DEBUG)
 530         post_error ("must specify -g?", gnat_node);
 531       break;
 532     }
 533
 534   return gnu_result;
 535 }
 536 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
 537    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
 538    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
 539
 540 static tree
 541 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 542 {
 543   tree gnu_result = error_mark_node;
 544   tree gnu_result_type;
 545   tree gnu_expr;
 546   bool prefix_unused = false;
 547   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
 548   tree gnu_type = TREE_TYPE (gnu_prefix);
 549
 550   /* If the input is a NULL_EXPR, make a new one.  */
 551   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
 552     {
 553       *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
 554       return build1 (NULL_EXPR, *gnu_result_type_p,
 555                      TREE_OPERAND (gnu_prefix, 0));
 556     }
 557
 558   switch (attribute)
 559     {
 560     case Attr_Pos:
 561     case Attr_Val:
 562       /* These are just conversions until since representation clauses for
 563          enumerations are handled in the front end.  */
 564       {
 565         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
 566
 567         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
 568         gnu_result_type = get_unpadded_type (Etype (gnat_node));
 569         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
 570                                          checkp, checkp, true);
 571       }
 572       break;
 573
 574     case Attr_Pred:
 575     case Attr_Succ:
 576       /* These just add or subject the constant 1.  Representation clauses for
 577          enumerations are handled in the front-end.  */
 578       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
 579       gnu_result_type = get_unpadded_type (Etype (gnat_node));
 580
 581       if (Do_Range_Check (First (Expressions (gnat_node))))
 582         {
 583           gnu_expr = protect_multiple_eval (gnu_expr);
 584           gnu_expr
 585             = emit_check
 586               (build_binary_op (EQ_EXPR, integer_type_node,
 587                                 gnu_expr,
 588                                 attribute == Attr_Pred
 589                                 ? TYPE_MIN_VALUE (gnu_result_type)
 590                                 : TYPE_MAX_VALUE (gnu_result_type)),
 591                gnu_expr, CE_Range_Check_Failed);
 592         }
 593
 594       gnu_result
 595         = build_binary_op (attribute == Attr_Pred
 596                            ? MINUS_EXPR : PLUS_EXPR,
 597                            gnu_result_type, gnu_expr,
 598                            convert (gnu_result_type, integer_one_node));
 599       break;
 600
 601     case Attr_Address:
 602     case Attr_Unrestricted_Access:
 603       /* Conversions don't change something's address but can cause us to miss
 604          the COMPONENT_REF case below, so strip them off.  */
 605       gnu_prefix = remove_conversions (gnu_prefix,
 606                                        !Must_Be_Byte_Aligned (gnat_node));
 607
 608       /* If we are taking 'Address of an unconstrained object, this is the
 609          pointer to the underlying array.  */
 610       if (attribute == Attr_Address)
 611         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
 612
 613       /* ... fall through ... */
 614
 615     case Attr_Access:
 616     case Attr_Unchecked_Access:
 617     case Attr_Code_Address:
 618       gnu_result_type = get_unpadded_type (Etype (gnat_node));
 619       gnu_result
 620         = build_unary_op (((attribute == Attr_Address
 621                             || attribute == Attr_Unrestricted_Access)
 622                            && !Must_Be_Byte_Aligned (gnat_node))
 623                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
 624                           gnu_result_type, gnu_prefix);
 625
 626       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
 627          don't try to build a trampoline.  */
 628       if (attribute == Attr_Code_Address)
 629         {
 630           for (gnu_expr = gnu_result;
 631                TREE_CODE (gnu_expr) == NOP_EXPR
 632                || TREE_CODE (gnu_expr) == CONVERT_EXPR;
 633                gnu_expr = TREE_OPERAND (gnu_expr, 0))
 634             TREE_CONSTANT (gnu_expr) = 1;
 635
 636           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
 637             TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
 638         }
 639       break;
 640
 641     case Attr_Pool_Address:
 642       {
 643         tree gnu_obj_type;
 644         tree gnu_ptr = gnu_prefix;
 645
 646         gnu_result_type = get_unpadded_type (Etype (gnat_node));
 647
 648         /* If this is an unconstrained array, we know the object must have been
 649            allocated with the template in front of the object.  So compute the
 650            template address.*/
 651         if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
 652           gnu_ptr
 653             = convert (build_pointer_type
 654                        (TYPE_OBJECT_RECORD_TYPE
 655                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
 656                        gnu_ptr);
 657
 658         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
 659         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
 660             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
 661           {
 662             tree gnu_char_ptr_type = build_pointer_type (char_type_node);
 663             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
 664             tree gnu_byte_offset
 665               = convert (gnu_char_ptr_type,
 666                          size_diffop (size_zero_node, gnu_pos));
 667
 668             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
 669             gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
 670                                        gnu_ptr, gnu_byte_offset);
 671           }
 672
 673         gnu_result = convert (gnu_result_type, gnu_ptr);
 674       }
 675       break;
 676
 677     case Attr_Size:
 678     case Attr_Object_Size:
 679     case Attr_Value_Size:
 680     case Attr_Max_Size_In_Storage_Elements:
 681       gnu_expr = gnu_prefix;
 682
 683       /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
 684          We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
 685       while (TREE_CODE (gnu_expr) == NOP_EXPR)
 686         gnu_expr = TREE_OPERAND (gnu_expr, 0)
 687           ;
 688
 689       gnu_prefix = remove_conversions (gnu_prefix, true);
 690       prefix_unused = true;
 691       gnu_type = TREE_TYPE (gnu_prefix);
 692
 693       /* Replace an unconstrained array type with the type of the underlying
 694          array.  We can't do this with a call to maybe_unconstrained_array
 695          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
 696          use the record type that will be used to allocate the object and its
 697          template.  */
 698       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
 699         {
 700           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
 701           if (attribute != Attr_Max_Size_In_Storage_Elements)
 702             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
 703         }
 704
 705       /* If we're looking for the size of a field, return the field size.
 706          Otherwise, if the prefix is an object, or if 'Object_Size or
 707          'Max_Size_In_Storage_Elements has been specified, the result is the
 708          GCC size of the type. Otherwise, the result is the RM_Size of the
 709          type.  */
 710       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
 711         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
 712       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
 713                || attribute == Attr_Object_Size
 714                || attribute == Attr_Max_Size_In_Storage_Elements)
 715         {
 716           /* If this is a padded type, the GCC size isn't relevant to the
 717              programmer.  Normally, what we want is the RM_Size, which was set
 718              from the specified size, but if it was not set, we want the size
 719              of the relevant field.  Using the MAX of those two produces the
 720              right result in all case.  Don't use the size of the field if it's
 721              a self-referential type, since that's never what's wanted.  */
 722           if (TREE_CODE (gnu_type) == RECORD_TYPE
 723               && TYPE_IS_PADDING_P (gnu_type)
 724               && TREE_CODE (gnu_expr) == COMPONENT_REF)
 725             {
 726               gnu_result = rm_size (gnu_type);
 727               if (!(CONTAINS_PLACEHOLDER_P
 728                     (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
 729                 gnu_result
 730                   = size_binop (MAX_EXPR, gnu_result,
 731                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
 732             }
 733           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
 734             {
 735               Node_Id gnat_deref = Prefix (gnat_node);
 736               Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
 737               tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
 738               if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
 739                 && Present (gnat_actual_subtype))
 740                 {
 741                   tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
 742                   gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
 743                                gnu_actual_obj_type, get_identifier ("SIZE"));
 744                 }
 745
 746               gnu_result = TYPE_SIZE (gnu_type);
 747             }
 748           else
 749             gnu_result = TYPE_SIZE (gnu_type);
 750         }
 751       else
 752         gnu_result = rm_size (gnu_type);
 753
 754       gcc_assert (gnu_result);
 755
 756       /* Deal with a self-referential size by returning the maximum size for a
 757          type and by qualifying the size with the object for 'Size of an
 758          object.  */
 759       if (CONTAINS_PLACEHOLDER_P (gnu_result))
 760         {
 761           if (TREE_CODE (gnu_prefix) != TYPE_DECL)
 762             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
 763           else
 764             gnu_result = max_size (gnu_result, true);
 765         }
 766
 767       /* If the type contains a template, subtract its size.  */
 768       if (TREE_CODE (gnu_type) == RECORD_TYPE
 769           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
 770         gnu_result = size_binop (MINUS_EXPR, gnu_result,
 771                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
 772
 773       gnu_result_type = get_unpadded_type (Etype (gnat_node));
 774
 775       /* Always perform division using unsigned arithmetic as the size cannot
 776          be negative, but may be an overflowed positive value. This provides
 777          correct results for sizes up to 512 MB.
 778
 779          ??? Size should be calculated in storage elements directly.  */
 780
 781       if (attribute == Attr_Max_Size_In_Storage_Elements)
 782         gnu_result = convert (sizetype,
 783                               fold (build2 (CEIL_DIV_EXPR, bitsizetype,
 784                                             gnu_result, bitsize_unit_node)));
 785       break;
 786
 787     case Attr_Alignment:
 788       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
 789           && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
 790               == RECORD_TYPE)
 791           && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
 792         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
 793
 794       gnu_type = TREE_TYPE (gnu_prefix);
 795       gnu_result_type = get_unpadded_type (Etype (gnat_node));
 796       prefix_unused = true;
 797
 798       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
 799         gnu_result = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)));
 800       else
 801         gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
 802       break;
 803
 804     case Attr_First:
 805     case Attr_Last:
 806     case Attr_Range_Length:
 807       prefix_unused = true;
 808
 809       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
 810         {
 811           gnu_result_type = get_unpadded_type (Etype (gnat_node));
 812
 813           if (attribute == Attr_First)
 814             gnu_result = TYPE_MIN_VALUE (gnu_type);
 815           else if (attribute == Attr_Last)
 816             gnu_result = TYPE_MAX_VALUE (gnu_type);
 817           else
 818             gnu_result
 819               = build_binary_op
 820                 (MAX_EXPR, get_base_type (gnu_result_type),
 821                  build_binary_op
 822                  (PLUS_EXPR, get_base_type (gnu_result_type),
 823                   build_binary_op (MINUS_EXPR,
 824                                    get_base_type (gnu_result_type),
 825                                    convert (gnu_result_type,
 826                                             TYPE_MAX_VALUE (gnu_type)),
 827                                    convert (gnu_result_type,
 828                                             TYPE_MIN_VALUE (gnu_type))),
 829                   convert (gnu_result_type, integer_one_node)),
 830                  convert (gnu_result_type, integer_zero_node));
 831
 832           break;
 833         }
 834
 835       /* ... fall through ... */
 836
 837     case Attr_Length:
 838       {
 839         int Dimension = (Present (Expressions (gnat_node))
 840                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
 841                          : 1);
 842
 843         /* Make sure any implicit dereference gets done.  */
 844         gnu_prefix = maybe_implicit_deref (gnu_prefix);
 845         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
 846         gnu_type = TREE_TYPE (gnu_prefix);
 847         prefix_unused = true;
 848         gnu_result_type = get_unpadded_type (Etype (gnat_node));
 849
 850         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
 851           {
 852             int ndim;
 853             tree gnu_type_temp;
 854
 855             for (ndim = 1, gnu_type_temp = gnu_type;
 856                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
 857                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
 858                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
 859               ;
 860
 861             Dimension = ndim + 1 - Dimension;
 862           }
 863
 864         for (; Dimension > 1; Dimension--)
 865           gnu_type = TREE_TYPE (gnu_type);
 866
 867         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
 868         if (attribute == Attr_First)
 869           gnu_result
 870             = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
 871         else if (attribute == Attr_Last)
 872           gnu_result
 873             = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
 874         else
 875           /* 'Length or 'Range_Length.  */
 876           {
 877             tree gnu_compute_type
 878               = gnat_signed_or_unsigned_type (0,
 879                                               get_base_type (gnu_result_type));
 880
 881             gnu_result
 882               = build_binary_op
 883                 (MAX_EXPR, gnu_compute_type,
 884                  build_binary_op
 885                  (PLUS_EXPR, gnu_compute_type,
 886                   build_binary_op
 887                   (MINUS_EXPR, gnu_compute_type,
 888                    convert (gnu_compute_type,
 889                             TYPE_MAX_VALUE
 890                             (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))),
 891                    convert (gnu_compute_type,
 892                             TYPE_MIN_VALUE
 893                             (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))),
 894                   convert (gnu_compute_type, integer_one_node)),
 895                  convert (gnu_compute_type, integer_zero_node));
 896           }
 897
 898         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
 899            handling.  Note that these attributes could not have been used on
 900            an unconstrained array type.  */
 901         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
 902                                                      gnu_prefix);
 903         break;
 904       }
 905
 906     case Attr_Bit_Position:
 907     case Attr_Position:
 908     case Attr_First_Bit:
 909     case Attr_Last_Bit:
 910     case Attr_Bit:
 911       {
 912         HOST_WIDE_INT bitsize;
 913         HOST_WIDE_INT bitpos;
 914         tree gnu_offset;
 915         tree gnu_field_bitpos;
 916         tree gnu_field_offset;
 917         tree gnu_inner;
 918         enum machine_mode mode;
 919         int unsignedp, volatilep;
 920
 921         gnu_result_type = get_unpadded_type (Etype (gnat_node));
 922         gnu_prefix = remove_conversions (gnu_prefix, true);
 923         prefix_unused = true;
 924
 925         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
 926            the result is 0.  Don't allow 'Bit on a bare component, though. */
 927         if (attribute == Attr_Bit
 928             && TREE_CODE (gnu_prefix) != COMPONENT_REF
 929             && TREE_CODE (gnu_prefix) != FIELD_DECL)
 930           {
 931             gnu_result = integer_zero_node;
 932             break;
 933           }
 934
 935         else
 936           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
 937                       || (attribute == Attr_Bit_Position
 938                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
 939
 940         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
 941                              &mode, &unsignedp, &volatilep, false);
 942
 943         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
 944           {
 945             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
 946             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
 947
 948             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
 949                  TREE_CODE (gnu_inner) == COMPONENT_REF
 950                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
 951                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
 952               {
 953                 gnu_field_bitpos
 954                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
 955                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
 956                 gnu_field_offset
 957                   = size_binop (PLUS_EXPR, gnu_field_offset,
 958                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
 959               }
 960           }
 961         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
 962           {
 963             gnu_field_bitpos = bit_position (gnu_prefix);
 964             gnu_field_offset = byte_position (gnu_prefix);
 965           }
 966         else
 967           {
 968             gnu_field_bitpos = bitsize_zero_node;
 969             gnu_field_offset = size_zero_node;
 970           }
 971
 972         switch (attribute)
 973           {
 974           case Attr_Position:
 975             gnu_result = gnu_field_offset;
 976             break;
 977
 978           case Attr_First_Bit:
 979           case Attr_Bit:
 980             gnu_result = size_int (bitpos % BITS_PER_UNIT);
 981             break;
 982
 983           case Attr_Last_Bit:
 984             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
 985             gnu_result = size_binop (PLUS_EXPR, gnu_result,
 986                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
 987             gnu_result = size_binop (MINUS_EXPR, gnu_result,
 988                                      bitsize_one_node);
 989             break;
 990
 991           case Attr_Bit_Position:
 992             gnu_result = gnu_field_bitpos;
 993             break;
 994                 }
 995
 996         /* If this has a PLACEHOLDER_EXPR, qualify it by the object
 997            we are handling. */
 998         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
 999         break;
1000       }
1001
1002     case Attr_Min:
1003     case Attr_Max:
1004       {
1005         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1006         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1007
1008         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1009         gnu_result = build_binary_op (attribute == Attr_Min
1010                                       ? MIN_EXPR : MAX_EXPR,
1011                                       gnu_result_type, gnu_lhs, gnu_rhs);
1012       }
1013       break;
1014
1015     case Attr_Passed_By_Reference:
1016       gnu_result = size_int (default_pass_by_ref (gnu_type)
1017                              || must_pass_by_ref (gnu_type));
1018       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1019       break;
1020
1021     case Attr_Component_Size:
1022       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1023           && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1024               == RECORD_TYPE)
1025           && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1026         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1027
1028       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1029       gnu_type = TREE_TYPE (gnu_prefix);
1030
1031       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1032         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1033
1034       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1035              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1036         gnu_type = TREE_TYPE (gnu_type);
1037
1038       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1039
1040       /* Note this size cannot be self-referential.  */
1041       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1042       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1043       prefix_unused = true;
1044       break;
1045
1046     case Attr_Null_Parameter:
1047       /* This is just a zero cast to the pointer type for
1048          our prefix and dereferenced.  */
1049       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1050       gnu_result
1051         = build_unary_op (INDIRECT_REF, NULL_TREE,
1052                           convert (build_pointer_type (gnu_result_type),
1053                                    integer_zero_node));
1054       TREE_PRIVATE (gnu_result) = 1;
1055       break;
1056
1057     case Attr_Mechanism_Code:
1058       {
1059         int code;
1060         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1061
1062         prefix_unused = true;
1063         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1064         if (Present (Expressions (gnat_node)))
1065           {
1066             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1067
1068             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1069                  i--, gnat_obj = Next_Formal (gnat_obj))
1070               ;
1071           }
1072
1073         code = Mechanism (gnat_obj);
1074         if (code == Default)
1075           code = ((present_gnu_tree (gnat_obj)
1076                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1077                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1078                             == PARM_DECL)
1079                            && (DECL_BY_COMPONENT_PTR_P
1080                                (get_gnu_tree (gnat_obj))))))
1081                   ? By_Reference : By_Copy);
1082         gnu_result = convert (gnu_result_type, size_int (- code));
1083       }
1084       break;
1085
1086     default:
1087       /* Say we have an unimplemented attribute.  Then set the value to be
1088          returned to be a zero and hope that's something we can convert to the
1089          type of this attribute.  */
1090       post_error ("unimplemented attribute", gnat_node);
1091       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1092       gnu_result = integer_zero_node;
1093       break;
1094     }
1095
1096   /* If this is an attribute where the prefix was unused, force a use of it if
1097      it has a side-effect.  But don't do it if the prefix is just an entity
1098      name.  However, if an access check is needed, we must do it.  See second
1099      example in AARM 11.6(5.e). */
1100   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1101       && !Is_Entity_Name (Prefix (gnat_node)))
1102     gnu_result = fold (build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1103                                gnu_prefix, gnu_result));
1104
1105   *gnu_result_type_p = gnu_result_type;
1106   return gnu_result;
1107 }
1108 \f
1109 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1110    to a GCC tree, which is returned.  */
1111
1112 static tree
1113 Case_Statement_to_gnu (Node_Id gnat_node)
1114 {
1115   tree gnu_result;
1116   tree gnu_expr;
1117   Node_Id gnat_when;
1118
1119   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1120   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1121
1122   /*  The range of values in a case statement is determined by the rules in
1123       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1124       of the expression. One exception arises in the case of a simple name that
1125       is parenthesized. This still has the Etype of the name, but since it is
1126       not a name, para 7 does not apply, and we need to go to the base type.
1127       This is the only case where parenthesization affects the dynamic
1128       semantics (i.e. the range of possible values at runtime that is covered
1129       by the others alternative.
1130
1131       Another exception is if the subtype of the expression is non-static.  In
1132       that case, we also have to use the base type.  */
1133   if (Paren_Count (Expression (gnat_node)) != 0
1134       || !Is_OK_Static_Subtype (Underlying_Type
1135                                 (Etype (Expression (gnat_node)))))
1136     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1137
1138   /* We build a SWITCH_EXPR that contains the code with interspersed
1139      CASE_LABEL_EXPRs for each label.  */
1140
1141   push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ());
1142   start_stmt_group ();
1143   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1144        Present (gnat_when);
1145        gnat_when = Next_Non_Pragma (gnat_when))
1146     {
1147       Node_Id gnat_choice;
1148
1149       /* First compile all the different case choices for the current WHEN
1150          alternative.  */
1151       for (gnat_choice = First (Discrete_Choices (gnat_when));
1152            Present (gnat_choice); gnat_choice = Next (gnat_choice))
1153         {
1154           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1155
1156           switch (Nkind (gnat_choice))
1157             {
1158             case N_Range:
1159               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1160               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1161               break;
1162
1163             case N_Subtype_Indication:
1164               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1165                                                 (Constraint (gnat_choice))));
1166               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1167                                                   (Constraint (gnat_choice))));
1168               break;
1169
1170             case N_Identifier:
1171             case N_Expanded_Name:
1172               /* This represents either a subtype range or a static value of
1173                  some kind; Ekind says which.  If a static value, fall through
1174                  to the next case.  */
1175               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1176                 {
1177                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1178
1179                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1180                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1181                   break;
1182                 }
1183
1184               /* ... fall through ... */
1185
1186             case N_Character_Literal:
1187             case N_Integer_Literal:
1188               gnu_low = gnat_to_gnu (gnat_choice);
1189               break;
1190
1191             case N_Others_Choice:
1192               break;
1193
1194             default:
1195               gcc_unreachable ();
1196             }
1197
1198           add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
1199                                       gnu_low, gnu_high,
1200                                       create_artificial_label ()),
1201                               gnat_choice);
1202         }
1203
1204       /* Push a binding level here in case variables are declared since we want
1205          them to be local to this set of statements instead of the block
1206          containing the Case statement.  */
1207       add_stmt (build_stmt_group (Statements (gnat_when), true));
1208       add_stmt (build1 (GOTO_EXPR, void_type_node,
1209                         TREE_VALUE (gnu_switch_label_stack)));
1210     }
1211
1212   /* Now emit a definition of the label all the cases branched to. */
1213   add_stmt (build1 (LABEL_EXPR, void_type_node,
1214                     TREE_VALUE (gnu_switch_label_stack)));
1215   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
1216                        end_stmt_group (), NULL_TREE);
1217   pop_stack (&gnu_switch_label_stack);
1218
1219   return gnu_result;
1220 }
1221 \f
1222 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
1223    to a GCC tree, which is returned.  */
1224
1225 static tree
1226 Loop_Statement_to_gnu (Node_Id gnat_node)
1227 {
1228   /* ??? It would be nice to use "build" here, but there's no build5.  */
1229   tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
1230                                  NULL_TREE, NULL_TREE, NULL_TREE);
1231   tree gnu_loop_var = NULL_TREE;
1232   Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
1233   tree gnu_cond_expr = NULL_TREE;
1234   tree gnu_result;
1235
1236   TREE_TYPE (gnu_loop_stmt) = void_type_node;
1237   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
1238   LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label ();
1239   annotate_with_node (gnu_loop_stmt, gnat_node);
1240
1241   /* Save the end label of this LOOP_STMT in a stack so that the corresponding
1242      N_Exit_Statement can find it.  */
1243   push_stack (&gnu_loop_label_stack, NULL_TREE,
1244               LOOP_STMT_LABEL (gnu_loop_stmt));
1245
1246   /* Set the condition that under which the loop should continue.
1247      For "LOOP .... END LOOP;" the condition is always true.  */
1248   if (No (gnat_iter_scheme))
1249     ;
1250   /* The case "WHILE condition LOOP ..... END LOOP;" */
1251   else if (Present (Condition (gnat_iter_scheme)))
1252     LOOP_STMT_TOP_COND (gnu_loop_stmt)
1253       = gnat_to_gnu (Condition (gnat_iter_scheme));
1254   else
1255     {
1256       /* We have an iteration scheme.  */
1257       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
1258       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
1259       Entity_Id gnat_type = Etype (gnat_loop_var);
1260       tree gnu_type = get_unpadded_type (gnat_type);
1261       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
1262       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
1263       bool reversep = Reverse_Present (gnat_loop_spec);
1264       tree gnu_first = reversep ? gnu_high : gnu_low;
1265       tree gnu_last = reversep ? gnu_low : gnu_high;
1266       enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
1267       tree gnu_base_type = get_base_type (gnu_type);
1268       tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
1269                         : TYPE_MAX_VALUE (gnu_base_type));
1270
1271       /* We know the loop variable will not overflow if GNU_LAST is a constant
1272          and is not equal to GNU_LIMIT.  If it might overflow, we have to move
1273          the limit test to the end of the loop.  In that case, we have to test
1274          for an empty loop outside the loop.  */
1275       if (TREE_CODE (gnu_last) != INTEGER_CST
1276           || TREE_CODE (gnu_limit) != INTEGER_CST
1277           || tree_int_cst_equal (gnu_last, gnu_limit))
1278         {
1279           gnu_cond_expr
1280             = build3 (COND_EXPR, void_type_node,
1281                       build_binary_op (LE_EXPR, integer_type_node,
1282                                        gnu_low, gnu_high),
1283                       NULL_TREE, alloc_stmt_list ());
1284           annotate_with_node (gnu_cond_expr, gnat_loop_spec);
1285         }
1286
1287       /* Open a new nesting level that will surround the loop to declare the
1288          loop index variable.  */
1289       start_stmt_group ();
1290       gnat_pushlevel ();
1291
1292       /* Declare the loop index and set it to its initial value.  */
1293       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
1294       if (DECL_BY_REF_P (gnu_loop_var))
1295         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
1296
1297       /* The loop variable might be a padded type, so use `convert' to get a
1298          reference to the inner variable if so.  */
1299       gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
1300
1301       /* Set either the top or bottom exit condition as appropriate depending
1302          on whether or not we know an overflow cannot occur. */
1303       if (gnu_cond_expr)
1304         LOOP_STMT_BOT_COND (gnu_loop_stmt)
1305           = build_binary_op (NE_EXPR, integer_type_node,
1306                              gnu_loop_var, gnu_last);
1307       else
1308         LOOP_STMT_TOP_COND (gnu_loop_stmt)
1309           = build_binary_op (end_code, integer_type_node,
1310                              gnu_loop_var, gnu_last);
1311
1312       LOOP_STMT_UPDATE (gnu_loop_stmt)
1313         = build_binary_op (reversep ? PREDECREMENT_EXPR
1314                            : PREINCREMENT_EXPR,
1315                            TREE_TYPE (gnu_loop_var),
1316                            gnu_loop_var,
1317                            convert (TREE_TYPE (gnu_loop_var),
1318                                     integer_one_node));
1319       annotate_with_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
1320                           gnat_iter_scheme);
1321     }
1322
1323   /* If the loop was named, have the name point to this loop.  In this case,
1324      the association is not a ..._DECL node, but the end label from this
1325      LOOP_STMT. */
1326   if (Present (Identifier (gnat_node)))
1327     save_gnu_tree (Entity (Identifier (gnat_node)),
1328                    LOOP_STMT_LABEL (gnu_loop_stmt), true);
1329
1330   /* Make the loop body into its own block, so any allocated storage will be
1331      released every iteration.  This is needed for stack allocation.  */
1332   LOOP_STMT_BODY (gnu_loop_stmt)
1333     = build_stmt_group (Statements (gnat_node), true);
1334
1335   /* If we declared a variable, then we are in a statement group for that
1336      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
1337   if (gnu_loop_var)
1338     {
1339       add_stmt (gnu_loop_stmt);
1340       gnat_poplevel ();
1341       gnu_loop_stmt = end_stmt_group ();
1342     }
1343
1344   /* If we have an outer COND_EXPR, that's our result and this loop is its
1345      "true" statement.  Otherwise, the result is the LOOP_STMT. */
1346   if (gnu_cond_expr)
1347     {
1348       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
1349       gnu_result = gnu_cond_expr;
1350       recalculate_side_effects (gnu_cond_expr);
1351     }
1352   else
1353     gnu_result = gnu_loop_stmt;
1354
1355   pop_stack (&gnu_loop_label_stack);
1356
1357   return gnu_result;
1358 }
1359 \f
1360 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
1361    handler for the current function.  */
1362
1363 /* This is implemented by issuing a call to the appropriate VMS specific
1364    builtin.  To avoid having VMS specific sections in the global gigi decls
1365    array, we maintain the decls of interest here.  We can't declare them
1366    inside the function because we must mark them never to be GC'd, which we
1367    can only do at the global level.  */
1368
1369 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
1370 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
1371
1372 static void
1373 establish_gnat_vms_condition_handler (void)
1374 {
1375   tree establish_stmt;
1376
1377   /* Elaborate the required decls on the first call.  Check on the decl for
1378      the gnat condition handler to decide, as this is one we create so we are
1379      sure that it will be non null on subsequent calls.  The builtin decl is
1380      looked up so remains null on targets where it is not implemented yet.  */
1381   if (gnat_vms_condition_handler_decl == NULL_TREE)
1382     {
1383       vms_builtin_establish_handler_decl
1384         = builtin_decl_for
1385           (get_identifier ("__builtin_establish_vms_condition_handler"));
1386
1387       gnat_vms_condition_handler_decl
1388         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
1389                                NULL_TREE,
1390                                build_function_type_list (integer_type_node,
1391                                                          ptr_void_type_node,
1392                                                          ptr_void_type_node,
1393                                                          NULL_TREE),
1394                                NULL_TREE, 0, 1, 1, 0, Empty);
1395     }
1396
1397   /* Do nothing if the establish builtin is not available, which might happen
1398      on targets where the facility is not implemented.  */
1399   if (vms_builtin_establish_handler_decl == NULL_TREE)
1400     return;
1401
1402   establish_stmt
1403     = build_call_1_expr (vms_builtin_establish_handler_decl,
1404                          build_unary_op
1405                          (ADDR_EXPR, NULL_TREE,
1406                           gnat_vms_condition_handler_decl));
1407
1408   add_stmt (establish_stmt);
1409 }
1410 \f
1411 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
1412    don't return anything.  */
1413
1414 static void
1415 Subprogram_Body_to_gnu (Node_Id gnat_node)
1416 {
1417   /* Save debug output mode in case it is reset.  */
1418   enum debug_info_type save_write_symbols = write_symbols;
1419   const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks;
1420   /* Defining identifier of a parameter to the subprogram.  */
1421   Entity_Id gnat_param;
1422   /* The defining identifier for the subprogram body. Note that if a
1423      specification has appeared before for this body, then the identifier
1424      occurring in that specification will also be a defining identifier and all
1425      the calls to this subprogram will point to that specification.  */
1426   Entity_Id gnat_subprog_id
1427     = (Present (Corresponding_Spec (gnat_node))
1428        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
1429   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
1430   tree gnu_subprog_decl;
1431   /* The FUNCTION_TYPE node corresponding to the subprogram spec.  */
1432   tree gnu_subprog_type;
1433   tree gnu_cico_list;
1434   tree gnu_result;
1435
1436   /* If this is a generic object or if it has been eliminated,
1437      ignore it.  */
1438   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
1439       || Ekind (gnat_subprog_id) == E_Generic_Function
1440       || Is_Eliminated (gnat_subprog_id))
1441     return;
1442
1443   /* If debug information is suppressed for the subprogram, turn debug
1444      mode off for the duration of processing.  */
1445   if (!Needs_Debug_Info (gnat_subprog_id))
1446     {
1447       write_symbols = NO_DEBUG;
1448       debug_hooks = &do_nothing_debug_hooks;
1449     }
1450
1451   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
1452      the already-elaborated tree node.  However, if this subprogram had its
1453      elaboration deferred, we will already have made a tree node for it.  So
1454      treat it as not being defined in that case.  Such a subprogram cannot
1455      have an address clause or a freeze node, so this test is safe, though it
1456      does disable some otherwise-useful error checking.  */
1457   gnu_subprog_decl
1458     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
1459                           Acts_As_Spec (gnat_node)
1460                           && !present_gnu_tree (gnat_subprog_id));
1461
1462   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
1463
1464   /* Set the line number in the decl to correspond to that of the body so that
1465      the line number notes are written
1466      correctly.  */
1467   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
1468
1469   begin_subprog_body (gnu_subprog_decl);
1470   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1471
1472   /* If there are OUT parameters, we need to ensure that the return statement
1473      properly copies them out.  We do this by making a new block and converting
1474      any inner return into a goto to a label at the end of the block.  */
1475   push_stack (&gnu_return_label_stack, NULL_TREE,
1476               gnu_cico_list ? create_artificial_label () : NULL_TREE);
1477
1478   /* Get a tree corresponding to the code for the subprogram.  */
1479   start_stmt_group ();
1480   gnat_pushlevel ();
1481
1482   /* See if there are any parameters for which we don't yet have GCC entities.
1483      These must be for OUT parameters for which we will be making VAR_DECL
1484      nodes here.  Fill them in to TYPE_CI_CO_LIST, which must contain the empty
1485      entry as well.  We can match up the entries because TYPE_CI_CO_LIST is in
1486      the order of the parameters.  */
1487   for (gnat_param = First_Formal (gnat_subprog_id);
1488        Present (gnat_param);
1489        gnat_param = Next_Formal_With_Extras (gnat_param))
1490     if (!present_gnu_tree (gnat_param))
1491       {
1492         /* Skip any entries that have been already filled in; they must
1493            correspond to IN OUT parameters.  */
1494         for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
1495              gnu_cico_list = TREE_CHAIN (gnu_cico_list))
1496           ;
1497
1498         /* Do any needed references for padded types.  */
1499         TREE_VALUE (gnu_cico_list)
1500           = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
1501                      gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
1502       }
1503
1504
1505   /* On VMS, establish our condition handler to possibly turn a condition into
1506      the corresponding exception if the subprogram has a foreign convention or
1507      is exported.
1508
1509      To ensure proper execution of local finalizations on condition instances,
1510      we must turn a condition into the corresponding exception even if there
1511      is no applicable Ada handler, and need at least one condition handler per
1512      possible call chain involving GNAT code.  OTOH, establishing the handler
1513      has a cost so we want to minimize the number of subprograms into which this
1514      happens.  The foreign or exported condition is expected to satisfy all
1515      the constraints.  */
1516   if (TARGET_ABI_OPEN_VMS
1517       && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node)))
1518     establish_gnat_vms_condition_handler ();
1519
1520   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
1521
1522   /* Generate the code of the subprogram itself.  A return statement will be
1523      present and any OUT parameters will be handled there.  */
1524   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
1525   gnat_poplevel ();
1526   gnu_result = end_stmt_group ();
1527
1528   /* If we made a special return label, we need to make a block that contains
1529      the definition of that label and the copying to the return value.  That
1530      block first contains the function, then the label and copy statement.  */
1531   if (TREE_VALUE (gnu_return_label_stack))
1532     {
1533       tree gnu_retval;
1534
1535       start_stmt_group ();
1536       gnat_pushlevel ();
1537       add_stmt (gnu_result);
1538       add_stmt (build1 (LABEL_EXPR, void_type_node,
1539                         TREE_VALUE (gnu_return_label_stack)));
1540
1541       gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1542       if (list_length (gnu_cico_list) == 1)
1543         gnu_retval = TREE_VALUE (gnu_cico_list);
1544       else
1545         gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
1546                                              gnu_cico_list);
1547
1548       if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
1549         gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
1550
1551       add_stmt_with_node
1552         (build_return_expr (DECL_RESULT (current_function_decl), gnu_retval),
1553          gnat_node);
1554       gnat_poplevel ();
1555       gnu_result = end_stmt_group ();
1556     }
1557
1558   pop_stack (&gnu_return_label_stack);
1559
1560   /* Initialize the information node for the function and set the
1561      end location.  */
1562   allocate_struct_function (current_function_decl);
1563   Sloc_to_locus
1564     ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
1565       ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
1566       : Sloc (gnat_node)),
1567      &cfun->function_end_locus);
1568
1569   end_subprog_body (gnu_result);
1570
1571   /* Disconnect the trees for parameters that we made variables for from the
1572      GNAT entities since these are unusable after we end the function.  */
1573   for (gnat_param = First_Formal (gnat_subprog_id);
1574        Present (gnat_param);
1575        gnat_param = Next_Formal_With_Extras (gnat_param))
1576     if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
1577       save_gnu_tree (gnat_param, NULL_TREE, false);
1578
1579   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
1580   write_symbols = save_write_symbols;
1581   debug_hooks = save_debug_hooks;
1582 }
1583 \f
1584 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
1585    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
1586    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
1587    If GNU_TARGET is non-null, this must be a function call and the result
1588    of the call is to be placed into that object.  */
1589
1590 static tree
1591 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
1592 {
1593   tree gnu_result;
1594   /* The GCC node corresponding to the GNAT subprogram name.  This can either
1595      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
1596      or an indirect reference expression (an INDIRECT_REF node) pointing to a
1597      subprogram.  */
1598   tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
1599   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
1600   tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
1601   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE,
1602                                           gnu_subprog_node);
1603   Entity_Id gnat_formal;
1604   Node_Id gnat_actual;
1605   tree gnu_actual_list = NULL_TREE;
1606   tree gnu_name_list = NULL_TREE;
1607   tree gnu_before_list = NULL_TREE;
1608   tree gnu_after_list = NULL_TREE;
1609   tree gnu_subprog_call;
1610
1611   switch (Nkind (Name (gnat_node)))
1612     {
1613     case N_Identifier:
1614     case N_Operator_Symbol:
1615     case N_Expanded_Name:
1616     case N_Attribute_Reference:
1617       if (Is_Eliminated (Entity (Name (gnat_node))))
1618         Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
1619     }
1620
1621   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
1622
1623   /* If we are calling a stubbed function, make this into a raise of
1624      Program_Error.  Elaborate all our args first.  */
1625   if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
1626       && DECL_STUBBED_P (gnu_subprog_node))
1627     {
1628       for (gnat_actual = First_Actual (gnat_node);
1629            Present (gnat_actual);
1630            gnat_actual = Next_Actual (gnat_actual))
1631         add_stmt (gnat_to_gnu (gnat_actual));
1632
1633       {
1634         tree call_expr
1635           = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node);
1636
1637         if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
1638           {
1639             *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
1640             return build1 (NULL_EXPR, *gnu_result_type_p, call_expr);
1641           }
1642         else
1643           return call_expr;
1644       }
1645     }
1646
1647   /* If we are calling by supplying a pointer to a target, set up that
1648      pointer as the first argument.  Use GNU_TARGET if one was passed;
1649      otherwise, make a target by building a variable of the maximum size
1650      of the type.  */
1651   if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
1652     {
1653       tree gnu_real_ret_type
1654         = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
1655
1656       if (!gnu_target)
1657         {
1658           tree gnu_obj_type
1659             = maybe_pad_type (gnu_real_ret_type,
1660                               max_size (TYPE_SIZE (gnu_real_ret_type), true),
1661                               0, Etype (Name (gnat_node)), "PAD", false,
1662                               false, false);
1663
1664           /* ??? We may be about to create a static temporary if we happen to
1665              be at the global binding level.  That's a regression from what
1666              the 3.x back-end would generate in the same situation, but we
1667              don't have a mechanism in Gigi for creating automatic variables
1668              in the elaboration routines.  */
1669           gnu_target
1670             = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
1671                                NULL, false, false, false, false, NULL,
1672                                gnat_node);
1673         }
1674
1675       gnu_actual_list
1676         = tree_cons (NULL_TREE,
1677                      build_unary_op (ADDR_EXPR, NULL_TREE,
1678                                      unchecked_convert (gnu_real_ret_type,
1679                                                         gnu_target,
1680                                                         false)),
1681                      NULL_TREE);
1682
1683     }
1684
1685   /* The only way we can be making a call via an access type is if Name is an
1686      explicit dereference.  In that case, get the list of formal args from the
1687      type the access type is pointing to.  Otherwise, get the formals from
1688      entity being called.  */
1689   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
1690     gnat_formal = First_Formal (Etype (Name (gnat_node)));
1691   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
1692     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
1693     gnat_formal = 0;
1694   else
1695     gnat_formal = First_Formal (Entity (Name (gnat_node)));
1696
1697   /* Create the list of the actual parameters as GCC expects it, namely a chain
1698      of TREE_LIST nodes in which the TREE_VALUE field of each node is a
1699      parameter-expression and the TREE_PURPOSE field is null.  Skip OUT
1700      parameters not passed by reference and don't need to be copied in.  */
1701   for (gnat_actual = First_Actual (gnat_node);
1702        Present (gnat_actual);
1703        gnat_formal = Next_Formal_With_Extras (gnat_formal),
1704        gnat_actual = Next_Actual (gnat_actual))
1705     {
1706       tree gnu_formal
1707         = (present_gnu_tree (gnat_formal)
1708            ? get_gnu_tree (gnat_formal) : NULL_TREE);
1709       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
1710       /* We treat a conversion between aggregate types as if it is an
1711          unchecked conversion.  */
1712       bool unchecked_convert_p
1713         = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion
1714            || (Nkind (gnat_actual) == N_Type_Conversion
1715                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
1716       Node_Id gnat_name = (unchecked_convert_p
1717                            ? Expression (gnat_actual) : gnat_actual);
1718       tree gnu_name = gnat_to_gnu (gnat_name);
1719       tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
1720       tree gnu_actual;
1721
1722       /* If it's possible we may need to use this expression twice, make sure
1723          than any side-effects are handled via SAVE_EXPRs. Likewise if we need
1724          to force side-effects before the call.
1725
1726          ??? This is more conservative than we need since we don't need to do
1727          this for pass-by-ref with no conversion. If we are passing a
1728          non-addressable Out or In Out parameter by reference, pass the address
1729          of a copy and set up to copy back out after the call.  */
1730       if (Ekind (gnat_formal) != E_In_Parameter)
1731         {
1732           gnu_name = gnat_stabilize_reference (gnu_name, true);
1733
1734           if (!addressable_p (gnu_name)
1735               && gnu_formal
1736               && (DECL_BY_REF_P (gnu_formal)
1737                   || (TREE_CODE (gnu_formal) == PARM_DECL
1738                       && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
1739                           || (DECL_BY_DESCRIPTOR_P (gnu_formal))))))
1740             {
1741               tree gnu_copy = gnu_name;
1742               tree gnu_temp;
1743
1744               /* For users of Starlet we issue a warning because the
1745                  interface apparently assumes that by-ref parameters
1746                  outlive the procedure invocation.  The code still
1747                  will not work as intended, but we cannot do much
1748                  better since other low-level parts of the back-end
1749                  would allocate temporaries at will because of the
1750                  misalignment if we did not do so here.  */
1751
1752               if (Is_Valued_Procedure (Entity (Name (gnat_node))))
1753                 {
1754                   post_error
1755                     ("?possible violation of implicit assumption",
1756                      gnat_actual);
1757                   post_error_ne
1758                     ("?made by pragma Import_Valued_Procedure on &",
1759                      gnat_actual, Entity (Name (gnat_node)));
1760                   post_error_ne
1761                     ("?because of misalignment of &",
1762                      gnat_actual, gnat_formal);
1763                 }
1764
1765               /* Remove any unpadding on the actual and make a copy.  But if
1766                  the actual is a justified modular type, first convert
1767                  to it.  */
1768               if (TREE_CODE (gnu_name) == COMPONENT_REF
1769                   && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
1770                        == RECORD_TYPE)
1771                       && (TYPE_IS_PADDING_P
1772                           (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
1773                 gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
1774               else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
1775                        && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)))
1776                 gnu_name = convert (gnu_name_type, gnu_name);
1777
1778               gnu_actual = save_expr (gnu_name);
1779
1780               /* Since we're going to take the address of the SAVE_EXPR, we
1781                  don't want it to be marked as unchanging. So set
1782                  TREE_ADDRESSABLE.  */
1783               gnu_temp = skip_simple_arithmetic (gnu_actual);
1784               if (TREE_CODE (gnu_temp) == SAVE_EXPR)
1785                 {
1786                   TREE_ADDRESSABLE (gnu_temp) = 1;
1787                   TREE_READONLY (gnu_temp) = 0;
1788                 }
1789
1790               /* Set up to move the copy back to the original.  */
1791               gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE,
1792                                           gnu_copy, gnu_actual);
1793               annotate_with_node (gnu_temp, gnat_actual);
1794               append_to_statement_list (gnu_temp, &gnu_after_list);
1795
1796               /* Account for next statement just below.  */
1797               gnu_name = gnu_actual;
1798             }
1799         }
1800
1801       /* If this was a procedure call, we may not have removed any padding.
1802          So do it here for the part we will use as an input, if any.  */
1803       gnu_actual = gnu_name;
1804       if (Ekind (gnat_formal) != E_Out_Parameter
1805           && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
1806           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
1807         gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
1808                               gnu_actual);
1809
1810       /* Unless this is an In parameter, we must remove any LJM building
1811          from GNU_NAME.  */
1812       if (Ekind (gnat_formal) != E_In_Parameter
1813           && TREE_CODE (gnu_name) == CONSTRUCTOR
1814           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
1815           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
1816         gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
1817                             gnu_name);
1818
1819       if (Ekind (gnat_formal) != E_Out_Parameter
1820           && !unchecked_convert_p
1821           && Do_Range_Check (gnat_actual))
1822         gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
1823
1824       /* Do any needed conversions.  We need only check for unchecked
1825          conversion since normal conversions will be handled by just
1826          converting to the formal type.  */
1827       if (unchecked_convert_p)
1828         {
1829           gnu_actual
1830             = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
1831                                  gnu_actual,
1832                                  (Nkind (gnat_actual)
1833                                   == N_Unchecked_Type_Conversion)
1834                                  && No_Truncation (gnat_actual));
1835
1836           /* One we've done the unchecked conversion, we still must ensure that
1837              the object is in range of the formal's type.  */
1838           if (Ekind (gnat_formal) != E_Out_Parameter
1839               && Do_Range_Check (gnat_actual))
1840             gnu_actual = emit_range_check (gnu_actual,
1841                                            Etype (gnat_formal));
1842         }
1843       else if (TREE_CODE (gnu_actual) != SAVE_EXPR)
1844         /* We may have suppressed a conversion to the Etype of the actual since
1845            the parent is a procedure call.  So add the conversion here.  */
1846         gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
1847                               gnu_actual);
1848
1849       if (TREE_CODE (gnu_actual) != SAVE_EXPR)
1850         gnu_actual = convert (gnu_formal_type, gnu_actual);
1851
1852       /* If we have not saved a GCC object for the formal, it means it is an
1853          OUT parameter not passed by reference and that does not need to be
1854          copied in. Otherwise, look at the PARM_DECL to see if it is passed by
1855          reference. */
1856       if (gnu_formal
1857           && TREE_CODE (gnu_formal) == PARM_DECL && DECL_BY_REF_P (gnu_formal))
1858         {
1859           if (Ekind (gnat_formal) != E_In_Parameter)
1860             {
1861               gnu_actual = gnu_name;
1862
1863               /* If we have a padded type, be sure we've removed padding.  */
1864               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
1865                   && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
1866                   && TREE_CODE (gnu_actual) != SAVE_EXPR)
1867                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
1868                                       gnu_actual);
1869
1870               /* If we have the constructed subtype of an aliased object
1871                  with an unconstrained nominal subtype, the type of the
1872                  actual includes the template, although it is formally
1873                  constrained.  So we need to convert it back to the real
1874                  constructed subtype to retrieve the constrained part
1875                  and takes its address.  */
1876               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
1877                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
1878                   && TREE_CODE (gnu_actual) != SAVE_EXPR
1879                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
1880                   && Is_Array_Type (Etype (gnat_actual)))
1881                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
1882                                       gnu_actual);
1883             }
1884
1885           /* Otherwise, if we have a non-addressable COMPONENT_REF of a
1886              variable-size type see if it's doing a unpadding operation.  If
1887              so, remove that operation since we have no way of allocating the
1888              required temporary.  */
1889           if (TREE_CODE (gnu_actual) == COMPONENT_REF
1890               && !TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
1891               && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0)))
1892                   == RECORD_TYPE)
1893               && TYPE_IS_PADDING_P (TREE_TYPE
1894                                     (TREE_OPERAND (gnu_actual, 0)))
1895               && !addressable_p (gnu_actual))
1896             gnu_actual = TREE_OPERAND (gnu_actual, 0);
1897
1898           /* The symmetry of the paths to the type of an entity is broken here
1899              since arguments don't know that they will be passed by ref. */
1900           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
1901           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
1902         }
1903       else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL
1904                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
1905         {
1906           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
1907           gnu_actual = maybe_implicit_deref (gnu_actual);
1908           gnu_actual = maybe_unconstrained_array (gnu_actual);
1909
1910           if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
1911               && TYPE_IS_PADDING_P (gnu_formal_type))
1912             {
1913               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
1914               gnu_actual = convert (gnu_formal_type, gnu_actual);
1915             }
1916
1917           /* Take the address of the object and convert to the proper pointer
1918              type.  We'd like to actually compute the address of the beginning
1919              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
1920              possibility that the ARRAY_REF might return a constant and we'd be
1921              getting the wrong address.  Neither approach is exactly correct,
1922              but this is the most likely to work in all cases.  */
1923           gnu_actual = convert (gnu_formal_type,
1924                                 build_unary_op (ADDR_EXPR, NULL_TREE,
1925                                                 gnu_actual));
1926         }
1927       else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL
1928                && DECL_BY_DESCRIPTOR_P (gnu_formal))
1929         {
1930           /* If arg is 'Null_Parameter, pass zero descriptor.  */
1931           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
1932                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
1933               && TREE_PRIVATE (gnu_actual))
1934             gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
1935                                   integer_zero_node);
1936           else
1937             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
1938                                          fill_vms_descriptor (gnu_actual,
1939                                                               gnat_formal));
1940         }
1941       else
1942         {
1943           tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
1944
1945           if (Ekind (gnat_formal) != E_In_Parameter)
1946             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
1947
1948           if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL)
1949             continue;
1950
1951           /* If this is 'Null_Parameter, pass a zero even though we are
1952              dereferencing it.  */
1953           else if (TREE_CODE (gnu_actual) == INDIRECT_REF
1954                    && TREE_PRIVATE (gnu_actual)
1955                    && host_integerp (gnu_actual_size, 1)
1956                    && 0 >= compare_tree_int (gnu_actual_size,
1957                                                    BITS_PER_WORD))
1958             gnu_actual
1959               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
1960                                    convert (gnat_type_for_size
1961                                             (tree_low_cst (gnu_actual_size, 1),
1962                                              1),
1963                                             integer_zero_node),
1964                                    false);
1965           else
1966             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
1967         }
1968
1969       gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
1970     }
1971
1972   gnu_subprog_call = build3 (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
1973                              gnu_subprog_addr, nreverse (gnu_actual_list),
1974                              NULL_TREE);
1975
1976   /* If we return by passing a target, we emit the call and return the target
1977      as our result.  */
1978   if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
1979     {
1980       add_stmt_with_node (gnu_subprog_call, gnat_node);
1981       *gnu_result_type_p
1982         = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
1983       return unchecked_convert (*gnu_result_type_p, gnu_target, false);
1984     }
1985
1986   /* If it is a function call, the result is the call expression unless
1987      a target is specified, in which case we copy the result into the target
1988      and return the assignment statement.  */
1989   else if (Nkind (gnat_node) == N_Function_Call)
1990     {
1991       gnu_result = gnu_subprog_call;
1992
1993       /* If the function returns an unconstrained array or by reference,
1994          we have to de-dereference the pointer.  */
1995       if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
1996           || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
1997         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1998
1999       if (gnu_target)
2000         gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2001                                       gnu_target, gnu_result);
2002       else
2003         *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
2004
2005       return gnu_result;
2006     }
2007
2008   /* If this is the case where the GNAT tree contains a procedure call
2009      but the Ada procedure has copy in copy out parameters, the special
2010      parameter passing mechanism must be used.  */
2011   else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
2012     {
2013       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
2014          in copy out parameters.  */
2015       tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2016       int length = list_length (scalar_return_list);
2017
2018       if (length > 1)
2019         {
2020           tree gnu_name;
2021
2022           gnu_subprog_call = save_expr (gnu_subprog_call);
2023           gnu_name_list = nreverse (gnu_name_list);
2024
2025           /* If any of the names had side-effects, ensure they are all
2026              evaluated before the call.  */
2027           for (gnu_name = gnu_name_list; gnu_name;
2028                gnu_name = TREE_CHAIN (gnu_name))
2029             if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
2030               append_to_statement_list (TREE_VALUE (gnu_name),
2031                                         &gnu_before_list);
2032         }
2033
2034       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2035         gnat_formal = First_Formal (Etype (Name (gnat_node)));
2036       else
2037         gnat_formal = First_Formal (Entity (Name (gnat_node)));
2038
2039       for (gnat_actual = First_Actual (gnat_node);
2040            Present (gnat_actual);
2041            gnat_formal = Next_Formal_With_Extras (gnat_formal),
2042            gnat_actual = Next_Actual (gnat_actual))
2043         /* If we are dealing with a copy in copy out parameter, we must
2044            retrieve its value from the record returned in the call.  */
2045         if (!(present_gnu_tree (gnat_formal)
2046               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2047               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2048                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2049                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2050                            || (DECL_BY_DESCRIPTOR_P
2051                                (get_gnu_tree (gnat_formal))))))))
2052             && Ekind (gnat_formal) != E_In_Parameter)
2053           {
2054             /* Get the value to assign to this OUT or IN OUT parameter.  It is
2055                either the result of the function if there is only a single such
2056                parameter or the appropriate field from the record returned.  */
2057             tree gnu_result
2058               = length == 1 ? gnu_subprog_call
2059                 : build_component_ref (gnu_subprog_call, NULL_TREE,
2060                                        TREE_PURPOSE (scalar_return_list),
2061                                        false);
2062             bool unchecked_conversion = (Nkind (gnat_actual)
2063                                          == N_Unchecked_Type_Conversion);
2064             /* If the actual is a conversion, get the inner expression, which
2065                will be the real destination, and convert the result to the
2066                type of the actual parameter.  */
2067             tree gnu_actual
2068               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
2069
2070             /* If the result is a padded type, remove the padding.  */
2071             if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
2072                 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
2073               gnu_result = convert (TREE_TYPE (TYPE_FIELDS
2074                                                (TREE_TYPE (gnu_result))),
2075                                     gnu_result);
2076
2077             /* If the result is a type conversion, do it.  */
2078             if (Nkind (gnat_actual) == N_Type_Conversion)
2079               gnu_result
2080                 = convert_with_check
2081                   (Etype (Expression (gnat_actual)), gnu_result,
2082                    Do_Overflow_Check (gnat_actual),
2083                    Do_Range_Check (Expression (gnat_actual)),
2084                    Float_Truncate (gnat_actual));
2085
2086             else if (unchecked_conversion)
2087               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
2088                                               gnu_result,
2089                                               No_Truncation (gnat_actual));
2090             else
2091               {
2092                 if (Do_Range_Check (gnat_actual))
2093                   gnu_result = emit_range_check (gnu_result,
2094                                                  Etype (gnat_actual));
2095
2096                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2097                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
2098                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
2099               }
2100
2101             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2102                                           gnu_actual, gnu_result);
2103             annotate_with_node (gnu_result, gnat_actual);
2104             append_to_statement_list (gnu_result, &gnu_before_list);
2105             scalar_return_list = TREE_CHAIN (scalar_return_list);
2106             gnu_name_list = TREE_CHAIN (gnu_name_list);
2107           }
2108         }
2109   else
2110     {
2111       annotate_with_node (gnu_subprog_call, gnat_node);
2112       append_to_statement_list (gnu_subprog_call, &gnu_before_list);
2113     }
2114
2115   append_to_statement_list (gnu_after_list, &gnu_before_list);
2116   return gnu_before_list;
2117 }
2118 \f
2119 /* Subroutine of gnat_to_gnu to translate gnat_node, an
2120    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
2121
2122 static tree
2123 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
2124 {
2125   tree gnu_jmpsave_decl = NULL_TREE;
2126   tree gnu_jmpbuf_decl = NULL_TREE;
2127   /* If just annotating, ignore all EH and cleanups.  */
2128   bool gcc_zcx = (!type_annotate_only
2129                   && Present (Exception_Handlers (gnat_node))
2130                   && Exception_Mechanism == Back_End_Exceptions);
2131   bool setjmp_longjmp
2132     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
2133        && Exception_Mechanism == Setjmp_Longjmp);
2134   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
2135   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
2136   tree gnu_inner_block; /* The statement(s) for the block itself.  */
2137   tree gnu_result;
2138   tree gnu_expr;
2139   Node_Id gnat_temp;
2140
2141   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
2142      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
2143      add_cleanup, and when we leave the binding, end_stmt_group will create
2144      the TRY_FINALLY_EXPR.
2145
2146      ??? The region level calls down there have been specifically put in place
2147      for a ZCX context and currently the order in which things are emitted
2148      (region/handlers) is different from the SJLJ case. Instead of putting
2149      other calls with different conditions at other places for the SJLJ case,
2150      it seems cleaner to reorder things for the SJLJ case and generalize the
2151      condition to make it not ZCX specific.
2152
2153      If there are any exceptions or cleanup processing involved, we need an
2154      outer statement group (for Setjmp_Longjmp) and binding level.  */
2155   if (binding_for_block)
2156     {
2157       start_stmt_group ();
2158       gnat_pushlevel ();
2159     }
2160
2161   /* If we are to call a function when exiting this block add a cleanup
2162      to the binding level we made above.  */
2163   if (at_end)
2164     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))));
2165
2166   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
2167      area for address of previous buffer.  Do this first since we need to have
2168      the setjmp buf known for any decls in this block.  */
2169   if (setjmp_longjmp)
2170     {
2171       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
2172                                           NULL_TREE, jmpbuf_ptr_type,
2173                                           build_call_0_expr (get_jmpbuf_decl),
2174                                           false, false, false, false, NULL,
2175                                           gnat_node);
2176       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
2177                                          NULL_TREE, jmpbuf_type,
2178                                          NULL_TREE, false, false, false, false,
2179                                          NULL, gnat_node);
2180
2181       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
2182
2183       /* When we exit this block, restore the saved value.  */
2184       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
2185     }
2186
2187   /* Now build the tree for the declarations and statements inside this block.
2188      If this is SJLJ, set our jmp_buf as the current buffer.  */
2189   start_stmt_group ();
2190
2191   if (setjmp_longjmp)
2192     add_stmt (build_call_1_expr (set_jmpbuf_decl,
2193                                  build_unary_op (ADDR_EXPR, NULL_TREE,
2194                                                  gnu_jmpbuf_decl)));
2195
2196   if (Present (First_Real_Statement (gnat_node)))
2197     process_decls (Statements (gnat_node), Empty,
2198                    First_Real_Statement (gnat_node), true, true);
2199
2200   /* Generate code for each statement in the block.  */
2201   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
2202                     ? First_Real_Statement (gnat_node)
2203                     : First (Statements (gnat_node)));
2204        Present (gnat_temp); gnat_temp = Next (gnat_temp))
2205     add_stmt (gnat_to_gnu (gnat_temp));
2206   gnu_inner_block = end_stmt_group ();
2207
2208   /* Now generate code for the two exception models, if either is relevant for
2209      this block.  */
2210   if (setjmp_longjmp)
2211     {
2212       tree *gnu_else_ptr = 0;
2213       tree gnu_handler;
2214
2215       /* Make a binding level for the exception handling declarations and code
2216          and set up gnu_except_ptr_stack for the handlers to use.  */
2217       start_stmt_group ();
2218       gnat_pushlevel ();
2219
2220       push_stack (&gnu_except_ptr_stack, NULL_TREE,
2221                   create_var_decl (get_identifier ("EXCEPT_PTR"),
2222                                    NULL_TREE,
2223                                    build_pointer_type (except_type_node),
2224                                    build_call_0_expr (get_excptr_decl), false,
2225                                    false, false, false, NULL, gnat_node));
2226
2227       /* Generate code for each handler. The N_Exception_Handler case does the
2228          real work and returns a COND_EXPR for each handler, which we chain
2229          together here.  */
2230       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2231            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
2232         {
2233           gnu_expr = gnat_to_gnu (gnat_temp);
2234
2235           /* If this is the first one, set it as the outer one. Otherwise,
2236              point the "else" part of the previous handler to us. Then point
2237              to our "else" part.  */
2238           if (!gnu_else_ptr)
2239             add_stmt (gnu_expr);
2240           else
2241             *gnu_else_ptr = gnu_expr;
2242
2243           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
2244         }
2245
2246       /* If none of the exception handlers did anything, re-raise but do not
2247          defer abortion.  */
2248       gnu_expr = build_call_1_expr (raise_nodefer_decl,
2249                                     TREE_VALUE (gnu_except_ptr_stack));
2250       annotate_with_node (gnu_expr, gnat_node);
2251
2252       if (gnu_else_ptr)
2253         *gnu_else_ptr = gnu_expr;
2254       else
2255         add_stmt (gnu_expr);
2256
2257       /* End the binding level dedicated to the exception handlers and get the
2258          whole statement group.  */
2259       pop_stack (&gnu_except_ptr_stack);
2260       gnat_poplevel ();
2261       gnu_handler = end_stmt_group ();
2262
2263       /* If the setjmp returns 1, we restore our incoming longjmp value and
2264          then check the handlers.  */
2265       start_stmt_group ();
2266       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
2267                                              gnu_jmpsave_decl),
2268                           gnat_node);
2269       add_stmt (gnu_handler);
2270       gnu_handler = end_stmt_group ();
2271
2272       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
2273       gnu_result = build3 (COND_EXPR, void_type_node,
2274                            (build_call_1_expr
2275                             (setjmp_decl,
2276                              build_unary_op (ADDR_EXPR, NULL_TREE,
2277                                              gnu_jmpbuf_decl))),
2278                            gnu_handler, gnu_inner_block);
2279     }
2280   else if (gcc_zcx)
2281     {
2282       tree gnu_handlers;
2283
2284       /* First make a block containing the handlers.  */
2285       start_stmt_group ();
2286       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2287            Present (gnat_temp);
2288            gnat_temp = Next_Non_Pragma (gnat_temp))
2289         add_stmt (gnat_to_gnu (gnat_temp));
2290       gnu_handlers = end_stmt_group ();
2291
2292       /* Now make the TRY_CATCH_EXPR for the block.  */
2293       gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
2294                            gnu_inner_block, gnu_handlers);
2295     }
2296   else
2297     gnu_result = gnu_inner_block;
2298
2299   /* Now close our outer block, if we had to make one.  */
2300   if (binding_for_block)
2301     {
2302       add_stmt (gnu_result);
2303       gnat_poplevel ();
2304       gnu_result = end_stmt_group ();
2305     }
2306
2307   return gnu_result;
2308 }
2309 \f
2310 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2311    to a GCC tree, which is returned.  This is the variant for Setjmp_Longjmp
2312    exception handling.  */
2313
2314 static tree
2315 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
2316 {
2317   /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
2318      an "if" statement to select the proper exceptions.  For "Others", exclude
2319      exceptions where Handled_By_Others is nonzero unless the All_Others flag
2320      is set. For "Non-ada", accept an exception if "Lang" is 'V'.  */
2321   tree gnu_choice = integer_zero_node;
2322   tree gnu_body = build_stmt_group (Statements (gnat_node), false);
2323   Node_Id gnat_temp;
2324
2325   for (gnat_temp = First (Exception_Choices (gnat_node));
2326        gnat_temp; gnat_temp = Next (gnat_temp))
2327     {
2328       tree this_choice;
2329
2330       if (Nkind (gnat_temp) == N_Others_Choice)
2331         {
2332           if (All_Others (gnat_temp))
2333             this_choice = integer_one_node;
2334           else
2335             this_choice
2336               = build_binary_op
2337                 (EQ_EXPR, integer_type_node,
2338                  convert
2339                  (integer_type_node,
2340                   build_component_ref
2341                   (build_unary_op
2342                    (INDIRECT_REF, NULL_TREE,
2343                     TREE_VALUE (gnu_except_ptr_stack)),
2344                    get_identifier ("not_handled_by_others"), NULL_TREE,
2345                    false)),
2346                  integer_zero_node);
2347         }
2348
2349       else if (Nkind (gnat_temp) == N_Identifier
2350                || Nkind (gnat_temp) == N_Expanded_Name)
2351         {
2352           Entity_Id gnat_ex_id = Entity (gnat_temp);
2353           tree gnu_expr;
2354
2355           /* Exception may be a renaming. Recover original exception which is
2356              the one elaborated and registered.  */
2357           if (Present (Renamed_Object (gnat_ex_id)))
2358             gnat_ex_id = Renamed_Object (gnat_ex_id);
2359
2360           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2361
2362           this_choice
2363             = build_binary_op
2364               (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack),
2365                convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
2366                         build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
2367
2368           /* If this is the distinguished exception "Non_Ada_Error" (and we are
2369              in VMS mode), also allow a non-Ada exception (a VMS condition) t
2370              match.  */
2371           if (Is_Non_Ada_Error (Entity (gnat_temp)))
2372             {
2373               tree gnu_comp
2374                 = build_component_ref
2375                   (build_unary_op (INDIRECT_REF, NULL_TREE,
2376                                    TREE_VALUE (gnu_except_ptr_stack)),
2377                    get_identifier ("lang"), NULL_TREE, false);
2378
2379               this_choice
2380                 = build_binary_op
2381                   (TRUTH_ORIF_EXPR, integer_type_node,
2382                    build_binary_op (EQ_EXPR, integer_type_node, gnu_comp,
2383                                     build_int_cst (TREE_TYPE (gnu_comp), 'V')),
2384                    this_choice);
2385             }
2386         }
2387       else
2388         gcc_unreachable ();
2389
2390       gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
2391                                     gnu_choice, this_choice);
2392     }
2393
2394   return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
2395 }
2396 \f
2397 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2398    to a GCC tree, which is returned.  This is the variant for ZCX.  */
2399
2400 static tree
2401 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
2402 {
2403   tree gnu_etypes_list = NULL_TREE;
2404   tree gnu_expr;
2405   tree gnu_etype;
2406   tree gnu_current_exc_ptr;
2407   tree gnu_incoming_exc_ptr;
2408   Node_Id gnat_temp;
2409
2410   /* We build a TREE_LIST of nodes representing what exception types this
2411      handler can catch, with special cases for others and all others cases.
2412
2413      Each exception type is actually identified by a pointer to the exception
2414      id, or to a dummy object for "others" and "all others".
2415
2416      Care should be taken to ensure that the control flow impact of "others"
2417      and "all others" is known to GCC. lang_eh_type_covers is doing the trick
2418      currently.  */
2419   for (gnat_temp = First (Exception_Choices (gnat_node));
2420        gnat_temp; gnat_temp = Next (gnat_temp))
2421     {
2422       if (Nkind (gnat_temp) == N_Others_Choice)
2423         {
2424           tree gnu_expr
2425             = All_Others (gnat_temp) ? all_others_decl : others_decl;
2426
2427           gnu_etype
2428             = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2429         }
2430       else if (Nkind (gnat_temp) == N_Identifier
2431                || Nkind (gnat_temp) == N_Expanded_Name)
2432         {
2433           Entity_Id gnat_ex_id = Entity (gnat_temp);
2434
2435           /* Exception may be a renaming. Recover original exception which is
2436              the one elaborated and registered.  */
2437           if (Present (Renamed_Object (gnat_ex_id)))
2438             gnat_ex_id = Renamed_Object (gnat_ex_id);
2439
2440           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2441           gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2442
2443           /* The Non_Ada_Error case for VMS exceptions is handled
2444              by the personality routine.  */
2445         }
2446       else
2447         gcc_unreachable ();
2448
2449       /* The GCC interface expects NULL to be passed for catch all handlers, so
2450          it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
2451          is integer_zero_node.  It would not work, however, because GCC's
2452          notion of "catch all" is stronger than our notion of "others".  Until
2453          we correctly use the cleanup interface as well, doing that would
2454          prevent the "all others" handlers from being seen, because nothing
2455          can be caught beyond a catch all from GCC's point of view.  */
2456       gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
2457     }
2458
2459   start_stmt_group ();
2460   gnat_pushlevel ();
2461
2462   /* Expand a call to the begin_handler hook at the beginning of the handler,
2463      and arrange for a call to the end_handler hook to occur on every possible
2464      exit path.
2465
2466      The hooks expect a pointer to the low level occurrence. This is required
2467      for our stack management scheme because a raise inside the handler pushes
2468      a new occurrence on top of the stack, which means that this top does not
2469      necessarily match the occurrence this handler was dealing with.
2470
2471      The EXC_PTR_EXPR object references the exception occurrence being
2472      propagated. Upon handler entry, this is the exception for which the
2473      handler is triggered. This might not be the case upon handler exit,
2474      however, as we might have a new occurrence propagated by the handler's
2475      body, and the end_handler hook called as a cleanup in this context.
2476
2477      We use a local variable to retrieve the incoming value at handler entry
2478      time, and reuse it to feed the end_handler hook's argument at exit.  */
2479   gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
2480   gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
2481                                           ptr_type_node, gnu_current_exc_ptr,
2482                                           false, false, false, false, NULL,
2483                                           gnat_node);
2484
2485   add_stmt_with_node (build_call_1_expr (begin_handler_decl,
2486                                          gnu_incoming_exc_ptr),
2487                       gnat_node);
2488   add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr));
2489   add_stmt_list (Statements (gnat_node));
2490   gnat_poplevel ();
2491
2492   return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
2493                  end_stmt_group ());
2494 }
2495 \f
2496 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
2497
2498 static void
2499 Compilation_Unit_to_gnu (Node_Id gnat_node)
2500 {
2501   /* Make the decl for the elaboration procedure.  */
2502   bool body_p = (Defining_Entity (Unit (gnat_node)),
2503             Nkind (Unit (gnat_node)) == N_Package_Body
2504             || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
2505   Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
2506   tree gnu_elab_proc_decl
2507     = create_subprog_decl
2508       (create_concat_name (gnat_unit_entity,
2509                            body_p ? "elabb" : "elabs"),
2510        NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
2511        gnat_unit_entity);
2512   struct elab_info *info;
2513
2514   push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
2515
2516   DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
2517   allocate_struct_function (gnu_elab_proc_decl);
2518   Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
2519   cfun = 0;
2520
2521   /* For a body, first process the spec if there is one. */
2522   if (Nkind (Unit (gnat_node)) == N_Package_Body
2523       || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
2524               && !Acts_As_Spec (gnat_node)))
2525     add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
2526
2527   process_inlined_subprograms (gnat_node);
2528
2529   if (type_annotate_only)
2530     {
2531       elaborate_all_entities (gnat_node);
2532
2533       if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
2534           || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
2535           || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
2536         return;
2537     }
2538
2539   process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
2540                  true, true);
2541   add_stmt (gnat_to_gnu (Unit (gnat_node)));
2542
2543   /* Process any pragmas and actions following the unit.  */
2544   add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
2545   add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
2546
2547   /* Save away what we've made so far and record this potential elaboration
2548      procedure.  */
2549   info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
2550   set_current_block_context (gnu_elab_proc_decl);
2551   gnat_poplevel ();
2552   DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
2553   info->next = elab_info_list;
2554   info->elab_proc = gnu_elab_proc_decl;
2555   info->gnat_node = gnat_node;
2556   elab_info_list = info;
2557
2558   /* Generate elaboration code for this unit, if necessary, and say whether
2559      we did or not.  */
2560   pop_stack (&gnu_elab_proc_stack);
2561
2562   /* Generate functions to call static constructors and destructors
2563      for targets that do not support .ctors/.dtors sections.  These
2564      functions have magic names which are detected by collect2.  */
2565   if (static_ctors)
2566     build_global_cdtor ('I', &static_ctors);
2567
2568   if (static_dtors)
2569     build_global_cdtor ('D', &static_dtors);
2570 }
2571 \f
2572 /* This function is the driver of the GNAT to GCC tree transformation
2573    process.  It is the entry point of the tree transformer.  GNAT_NODE is the
2574    root of some GNAT tree.  Return the root of the corresponding GCC tree.
2575    If this is an expression, return the GCC equivalent of the expression.  If
2576    it is a statement, return the statement.  In the case when called for a
2577    statement, it may also add statements to the current statement group, in
2578    which case anything it returns is to be interpreted as occurring after
2579    anything `it already added.  */
2580
2581 tree
2582 gnat_to_gnu (Node_Id gnat_node)
2583 {
2584   bool went_into_elab_proc = false;
2585   tree gnu_result = error_mark_node; /* Default to no value. */
2586   tree gnu_result_type = void_type_node;
2587   tree gnu_expr;
2588   tree gnu_lhs, gnu_rhs;
2589   Node_Id gnat_temp;
2590
2591   /* Save node number for error message and set location information.  */
2592   error_gnat_node = gnat_node;
2593   Sloc_to_locus (Sloc (gnat_node), &input_location);
2594
2595   if (type_annotate_only
2596       && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call))
2597     return alloc_stmt_list ();
2598
2599   /* If this node is a non-static subexpression and we are only
2600      annotating types, make this into a NULL_EXPR.  */
2601   if (type_annotate_only
2602       && IN (Nkind (gnat_node), N_Subexpr)
2603       && Nkind (gnat_node) != N_Identifier
2604       && !Compile_Time_Known_Value (gnat_node))
2605     return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
2606                    build_call_raise (CE_Range_Check_Failed, gnat_node));
2607
2608   /* If this is a Statement and we are at top level, it must be part of the
2609      elaboration procedure, so mark us as being in that procedure and push our
2610      context.
2611
2612      If we are in the elaboration procedure, check if we are violating a a
2613      No_Elaboration_Code restriction by having a statement there.  */
2614   if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
2615        && Nkind (gnat_node) != N_Null_Statement)
2616       || Nkind (gnat_node) == N_Procedure_Call_Statement
2617       || Nkind (gnat_node) == N_Label
2618       || Nkind (gnat_node) == N_Implicit_Label_Declaration
2619       || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
2620       || ((Nkind (gnat_node) == N_Raise_Constraint_Error
2621            || Nkind (gnat_node) == N_Raise_Storage_Error
2622            || Nkind (gnat_node) == N_Raise_Program_Error)
2623           && (Ekind (Etype (gnat_node)) == E_Void)))
2624     {
2625       if (!current_function_decl)
2626         {
2627           current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
2628           start_stmt_group ();
2629           gnat_pushlevel ();
2630           went_into_elab_proc = true;
2631         }
2632
2633       /* Don't check for a possible No_Elaboration_Code restriction violation
2634          on N_Handled_Sequence_Of_Statements, as we want to signal an error on
2635          every nested real statement instead.  This also avoids triggering
2636          spurious errors on dummy (empty) sequences created by the front-end
2637          for package bodies in some cases.  */
2638
2639       if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
2640           && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
2641         Check_Elaboration_Code_Allowed (gnat_node);
2642     }
2643
2644   switch (Nkind (gnat_node))
2645     {
2646       /********************************/
2647       /* Chapter 2: Lexical Elements: */
2648       /********************************/
2649
2650     case N_Identifier:
2651     case N_Expanded_Name:
2652     case N_Operator_Symbol:
2653     case N_Defining_Identifier:
2654       gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
2655       break;
2656
2657     case N_Integer_Literal:
2658       {
2659         tree gnu_type;
2660
2661         /* Get the type of the result, looking inside any padding and
2662            justified modular types.  Then get the value in that type.  */
2663         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
2664
2665         if (TREE_CODE (gnu_type) == RECORD_TYPE
2666             && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2667           gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
2668
2669         gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
2670
2671         /* If the result overflows (meaning it doesn't fit in its base type),
2672            abort.  We would like to check that the value is within the range
2673            of the subtype, but that causes problems with subtypes whose usage
2674            will raise Constraint_Error and with biased representation, so
2675            we don't.  */
2676         gcc_assert (!TREE_CONSTANT_OVERFLOW (gnu_result));
2677       }
2678       break;
2679
2680     case N_Character_Literal:
2681       /* If a Entity is present, it means that this was one of the
2682          literals in a user-defined character type.  In that case,
2683          just return the value in the CONST_DECL.  Otherwise, use the
2684          character code.  In that case, the base type should be an
2685          INTEGER_TYPE, but we won't bother checking for that.  */
2686       gnu_result_type = get_unpadded_type (Etype (gnat_node));
2687       if (Present (Entity (gnat_node)))
2688         gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
2689       else
2690         gnu_result
2691           = force_fit_type
2692             (build_int_cst
2693               (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node))),
2694              false, false, false);
2695       break;
2696
2697     case N_Real_Literal:
2698       /* If this is of a fixed-point type, the value we want is the
2699          value of the corresponding integer.  */
2700       if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
2701         {
2702           gnu_result_type = get_unpadded_type (Etype (gnat_node));
2703           gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
2704                                   gnu_result_type);
2705           gcc_assert (!TREE_CONSTANT_OVERFLOW (gnu_result));
2706         }
2707
2708       /* We should never see a Vax_Float type literal, since the front end
2709          is supposed to transform these using appropriate conversions */
2710       else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
2711         gcc_unreachable ();
2712
2713       else
2714         {
2715           Ureal ur_realval = Realval (gnat_node);
2716
2717           gnu_result_type = get_unpadded_type (Etype (gnat_node));
2718
2719           /* If the real value is zero, so is the result.  Otherwise,
2720              convert it to a machine number if it isn't already.  That
2721              forces BASE to 0 or 2 and simplifies the rest of our logic.  */
2722           if (UR_Is_Zero (ur_realval))
2723             gnu_result = convert (gnu_result_type, integer_zero_node);
2724           else
2725             {
2726               if (!Is_Machine_Number (gnat_node))
2727                 ur_realval
2728                   = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
2729                              ur_realval, Round_Even, gnat_node);
2730
2731               gnu_result
2732                 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
2733
2734               /* If we have a base of zero, divide by the denominator.
2735                  Otherwise, the base must be 2 and we scale the value, which
2736                  we know can fit in the mantissa of the type (hence the use
2737                  of that type above).  */
2738               if (No (Rbase (ur_realval)))
2739                 gnu_result
2740                   = build_binary_op (RDIV_EXPR,
2741                                      get_base_type (gnu_result_type),
2742                                      gnu_result,
2743                                      UI_To_gnu (Denominator (ur_realval),
2744                                                 gnu_result_type));
2745               else
2746                 {
2747                   REAL_VALUE_TYPE tmp;
2748
2749                   gcc_assert (Rbase (ur_realval) == 2);
2750                   real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
2751                               - UI_To_Int (Denominator (ur_realval)));
2752                   gnu_result = build_real (gnu_result_type, tmp);
2753                 }
2754             }
2755
2756           /* Now see if we need to negate the result.  Do it this way to
2757              properly handle -0.  */
2758           if (UR_Is_Negative (Realval (gnat_node)))
2759             gnu_result
2760               = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
2761                                 gnu_result);
2762         }
2763
2764       break;
2765
2766     case N_String_Literal:
2767       gnu_result_type = get_unpadded_type (Etype (gnat_node));
2768       if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
2769         {
2770           String_Id gnat_string = Strval (gnat_node);
2771           int length = String_Length (gnat_string);
2772           char *string = (char *) alloca (length + 1);
2773           int i;
2774
2775           /* Build the string with the characters in the literal.  Note
2776              that Ada strings are 1-origin.  */
2777           for (i = 0; i < length; i++)
2778             string[i] = Get_String_Char (gnat_string, i + 1);
2779
2780           /* Put a null at the end of the string in case it's in a context
2781              where GCC will want to treat it as a C string.  */
2782           string[i] = 0;
2783
2784           gnu_result = build_string (length, string);
2785
2786           /* Strings in GCC don't normally have types, but we want
2787              this to not be converted to the array type.  */
2788           TREE_TYPE (gnu_result) = gnu_result_type;
2789         }
2790       else
2791         {
2792           /* Build a list consisting of each character, then make
2793              the aggregate.  */
2794           String_Id gnat_string = Strval (gnat_node);
2795           int length = String_Length (gnat_string);
2796           int i;
2797           tree gnu_list = NULL_TREE;
2798           tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
2799
2800           for (i = 0; i < length; i++)
2801             {
2802               gnu_list
2803                 = tree_cons (gnu_idx,
2804                              build_int_cst (TREE_TYPE (gnu_result_type),
2805                                             Get_String_Char (gnat_string,
2806                                                              i + 1)),
2807                              gnu_list);
2808
2809               gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
2810                                          0);
2811             }
2812
2813           gnu_result
2814             = gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
2815         }
2816       break;
2817
2818     case N_Pragma:
2819       gnu_result = Pragma_to_gnu (gnat_node);
2820       break;
2821
2822     /**************************************/
2823     /* Chapter 3: Declarations and Types: */
2824     /**************************************/
2825
2826     case N_Subtype_Declaration:
2827     case N_Full_Type_Declaration:
2828     case N_Incomplete_Type_Declaration:
2829     case N_Private_Type_Declaration:
2830     case N_Private_Extension_Declaration:
2831     case N_Task_Type_Declaration:
2832       process_type (Defining_Entity (gnat_node));
2833       gnu_result = alloc_stmt_list ();
2834       break;
2835
2836     case N_Object_Declaration:
2837     case N_Exception_Declaration:
2838       gnat_temp = Defining_Entity (gnat_node);
2839       gnu_result = alloc_stmt_list ();
2840
2841       /* If we are just annotating types and this object has an unconstrained
2842          or task type, don't elaborate it.   */
2843       if (type_annotate_only
2844           && (((Is_Array_Type (Etype (gnat_temp))
2845                 || Is_Record_Type (Etype (gnat_temp)))
2846                && !Is_Constrained (Etype (gnat_temp)))
2847             || Is_Concurrent_Type (Etype (gnat_temp))))
2848         break;
2849
2850       if (Present (Expression (gnat_node))
2851           && !(Nkind (gnat_node) == N_Object_Declaration
2852                && No_Initialization (gnat_node))
2853           && (!type_annotate_only
2854               || Compile_Time_Known_Value (Expression (gnat_node))))
2855         {
2856           gnu_expr = gnat_to_gnu (Expression (gnat_node));
2857           if (Do_Range_Check (Expression (gnat_node)))
2858             gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
2859
2860           /* If this object has its elaboration delayed, we must force
2861              evaluation of GNU_EXPR right now and save it for when the object
2862              is frozen.  */
2863           if (Present (Freeze_Node (gnat_temp)))
2864             {
2865               if ((Is_Public (gnat_temp) || global_bindings_p ())
2866                   && !TREE_CONSTANT (gnu_expr))
2867                 gnu_expr
2868                   = create_var_decl (create_concat_name (gnat_temp, "init"),
2869                                      NULL_TREE, TREE_TYPE (gnu_expr),
2870                                      gnu_expr, false, Is_Public (gnat_temp),
2871                                      false, false, NULL, gnat_temp);
2872               else
2873                 gnu_expr = maybe_variable (gnu_expr);
2874
2875               save_gnu_tree (gnat_node, gnu_expr, true);
2876             }
2877         }
2878       else
2879         gnu_expr = NULL_TREE;
2880
2881       if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
2882         gnu_expr = NULL_TREE;
2883
2884       if (No (Freeze_Node (gnat_temp)))
2885         gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
2886       break;
2887
2888     case N_Object_Renaming_Declaration:
2889       gnat_temp = Defining_Entity (gnat_node);
2890
2891       /* Don't do anything if this renaming is handled by the front end or if
2892          we are just annotating types and this object has a composite or task
2893          type, don't elaborate it.  We return the result in case it has any
2894          SAVE_EXPRs in it that need to be evaluated here.  */
2895       if (!Is_Renaming_Of_Object (gnat_temp)
2896           && ! (type_annotate_only
2897                 && (Is_Array_Type (Etype (gnat_temp))
2898                     || Is_Record_Type (Etype (gnat_temp))
2899                     || Is_Concurrent_Type (Etype (gnat_temp)))))
2900         gnu_result
2901           = gnat_to_gnu_entity (gnat_temp,
2902                                 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
2903       else
2904         gnu_result = alloc_stmt_list ();
2905       break;
2906
2907     case N_Implicit_Label_Declaration:
2908       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
2909       gnu_result = alloc_stmt_list ();
2910       break;
2911
2912     case N_Exception_Renaming_Declaration:
2913     case N_Number_Declaration:
2914     case N_Package_Renaming_Declaration:
2915     case N_Subprogram_Renaming_Declaration:
2916       /* These are fully handled in the front end.  */
2917       gnu_result = alloc_stmt_list ();
2918       break;
2919
2920     /*************************************/
2921     /* Chapter 4: Names and Expressions: */
2922     /*************************************/
2923
2924     case N_Explicit_Dereference:
2925       gnu_result = gnat_to_gnu (Prefix (gnat_node));
2926       gnu_result_type = get_unpadded_type (Etype (gnat_node));
2927       gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2928       break;
2929
2930     case N_Indexed_Component:
2931       {
2932         tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
2933         tree gnu_type;
2934         int ndim;
2935         int i;
2936         Node_Id *gnat_expr_array;
2937
2938         gnu_array_object = maybe_implicit_deref (gnu_array_object);
2939         gnu_array_object = maybe_unconstrained_array (gnu_array_object);
2940
2941         /* If we got a padded type, remove it too.  */
2942         if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
2943             && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
2944           gnu_array_object
2945             = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
2946                        gnu_array_object);
2947
2948         gnu_result = gnu_array_object;
2949
2950         /* First compute the number of dimensions of the array, then
2951            fill the expression array, the order depending on whether
2952            this is a Convention_Fortran array or not.  */
2953         for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
2954              TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2955              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
2956              ndim++, gnu_type = TREE_TYPE (gnu_type))
2957           ;
2958
2959         gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
2960
2961         if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
2962           for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
2963                i >= 0;
2964                i--, gnat_temp = Next (gnat_temp))
2965             gnat_expr_array[i] = gnat_temp;
2966         else
2967           for (i = 0, gnat_temp = First (Expressions (gnat_node));
2968                i < ndim;
2969                i++, gnat_temp = Next (gnat_temp))
2970             gnat_expr_array[i] = gnat_temp;
2971
2972         for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
2973              i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
2974           {
2975             gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2976             gnat_temp = gnat_expr_array[i];
2977             gnu_expr = gnat_to_gnu (gnat_temp);
2978
2979             if (Do_Range_Check (gnat_temp))
2980               gnu_expr
2981                 = emit_index_check
2982                   (gnu_array_object, gnu_expr,
2983                    TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
2984                    TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
2985
2986             gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
2987                                           gnu_result, gnu_expr);
2988           }
2989       }
2990
2991       gnu_result_type = get_unpadded_type (Etype (gnat_node));
2992       break;
2993
2994     case N_Slice:
2995       {
2996         tree gnu_type;
2997         Node_Id gnat_range_node = Discrete_Range (gnat_node);
2998
2999         gnu_result = gnat_to_gnu (Prefix (gnat_node));
3000         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3001
3002         /* Do any implicit dereferences of the prefix and do any needed
3003            range check.  */
3004         gnu_result = maybe_implicit_deref (gnu_result);
3005         gnu_result = maybe_unconstrained_array (gnu_result);
3006         gnu_type = TREE_TYPE (gnu_result);
3007         if (Do_Range_Check (gnat_range_node))
3008           {
3009             /* Get the bounds of the slice. */
3010             tree gnu_index_type
3011               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
3012             tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
3013             tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
3014             tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
3015
3016             /* Check to see that the minimum slice value is in range */
3017             gnu_expr_l
3018               = emit_index_check
3019                 (gnu_result, gnu_min_expr,
3020                  TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
3021                  TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
3022
3023             /* Check to see that the maximum slice value is in range */
3024             gnu_expr_h
3025               = emit_index_check
3026                 (gnu_result, gnu_max_expr,
3027                  TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
3028                  TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
3029
3030             /* Derive a good type to convert everything too */
3031             gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
3032
3033             /* Build a compound expression that does the range checks */
3034             gnu_expr
3035               = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
3036                                  convert (gnu_expr_type, gnu_expr_h),
3037                                  convert (gnu_expr_type, gnu_expr_l));
3038
3039             /* Build a conditional expression that returns the range checks
3040                expression if the slice range is not null (max >= min) or
3041                returns the min if the slice range is null */
3042             gnu_expr
3043               = fold (build3 (COND_EXPR, gnu_expr_type,
3044                               build_binary_op (GE_EXPR, gnu_expr_type,
3045                                                convert (gnu_expr_type,
3046                                                         gnu_max_expr),
3047                                                convert (gnu_expr_type,
3048                                                         gnu_min_expr)),
3049                               gnu_expr, gnu_min_expr));
3050           }
3051         else
3052           gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
3053
3054         gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
3055                                       gnu_result, gnu_expr);
3056       }
3057       break;
3058
3059     case N_Selected_Component:
3060       {
3061         tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
3062         Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
3063         Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
3064         tree gnu_field;
3065
3066         while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
3067                || IN (Ekind (gnat_pref_type), Access_Kind))
3068           {
3069             if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
3070               gnat_pref_type = Underlying_Type (gnat_pref_type);
3071             else if (IN (Ekind (gnat_pref_type), Access_Kind))
3072               gnat_pref_type = Designated_Type (gnat_pref_type);
3073           }
3074
3075         gnu_prefix = maybe_implicit_deref (gnu_prefix);
3076
3077         /* For discriminant references in tagged types always substitute the
3078            corresponding discriminant as the actual selected component. */
3079
3080         if (Is_Tagged_Type (gnat_pref_type))
3081           while (Present (Corresponding_Discriminant (gnat_field)))
3082             gnat_field = Corresponding_Discriminant (gnat_field);
3083
3084         /* For discriminant references of untagged types always substitute the
3085            corresponding stored discriminant. */
3086
3087         else if (Present (Corresponding_Discriminant (gnat_field)))
3088           gnat_field = Original_Record_Component (gnat_field);
3089
3090         /* Handle extracting the real or imaginary part of a complex.
3091            The real part is the first field and the imaginary the last.  */
3092
3093         if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
3094           gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
3095                                        ? REALPART_EXPR : IMAGPART_EXPR,
3096                                        NULL_TREE, gnu_prefix);
3097         else
3098           {
3099             gnu_field = gnat_to_gnu_field_decl (gnat_field);
3100
3101             /* If there are discriminants, the prefix might be
3102                evaluated more than once, which is a problem if it has
3103                side-effects. */
3104             if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
3105                                    ? Designated_Type (Etype
3106                                                       (Prefix (gnat_node)))
3107                                    : Etype (Prefix (gnat_node))))
3108               gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
3109
3110             gnu_result
3111               = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
3112                                      (Nkind (Parent (gnat_node))
3113                                       == N_Attribute_Reference));
3114           }
3115
3116         gcc_assert (gnu_result);
3117         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3118       }
3119       break;
3120
3121     case N_Attribute_Reference:
3122       {
3123         /* The attribute designator (like an enumeration value). */
3124         int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
3125
3126         /* The Elab_Spec and Elab_Body attributes are special in that
3127            Prefix is a unit, not an object with a GCC equivalent.  Similarly
3128            for Elaborated, since that variable isn't otherwise known.  */
3129         if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
3130           return (create_subprog_decl
3131                   (create_concat_name (Entity (Prefix (gnat_node)),
3132                                        attribute == Attr_Elab_Body
3133                                        ? "elabb" : "elabs"),
3134                    NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL,
3135                    gnat_node));
3136
3137         gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute);
3138       }
3139       break;
3140
3141     case N_Reference:
3142       /* Like 'Access as far as we are concerned.  */
3143       gnu_result = gnat_to_gnu (Prefix (gnat_node));
3144       gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
3145       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3146       break;
3147
3148     case N_Aggregate:
3149     case N_Extension_Aggregate:
3150       {
3151         tree gnu_aggr_type;
3152
3153         /* ??? It is wrong to evaluate the type now, but there doesn't
3154            seem to be any other practical way of doing it.  */
3155
3156         gcc_assert (!Expansion_Delayed (gnat_node));
3157
3158         gnu_aggr_type = gnu_result_type
3159           = get_unpadded_type (Etype (gnat_node));
3160
3161         if (TREE_CODE (gnu_result_type) == RECORD_TYPE
3162             && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
3163           gnu_aggr_type
3164             = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
3165
3166         if (Null_Record_Present (gnat_node))
3167           gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
3168
3169         else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
3170                  || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
3171           gnu_result
3172             = assoc_to_constructor (Etype (gnat_node),
3173                                     First (Component_Associations (gnat_node)),
3174                                     gnu_aggr_type);
3175         else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
3176           gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
3177                                            gnu_aggr_type,
3178                                            Component_Type (Etype (gnat_node)));
3179         else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
3180           gnu_result
3181             = build_binary_op
3182               (COMPLEX_EXPR, gnu_aggr_type,
3183                gnat_to_gnu (Expression (First
3184                                         (Component_Associations (gnat_node)))),
3185                gnat_to_gnu (Expression
3186                             (Next
3187                              (First (Component_Associations (gnat_node))))));
3188         else
3189           gcc_unreachable ();
3190
3191         gnu_result = convert (gnu_result_type, gnu_result);
3192       }
3193       break;
3194
3195     case N_Null:
3196       gnu_result = null_pointer_node;
3197       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3198       break;
3199
3200     case N_Type_Conversion:
3201     case N_Qualified_Expression:
3202       /* Get the operand expression.  */
3203       gnu_result = gnat_to_gnu (Expression (gnat_node));
3204       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3205
3206       gnu_result
3207         = convert_with_check (Etype (gnat_node), gnu_result,
3208                               Do_Overflow_Check (gnat_node),
3209                               Do_Range_Check (Expression (gnat_node)),
3210                               Nkind (gnat_node) == N_Type_Conversion
3211                               && Float_Truncate (gnat_node));
3212       break;
3213
3214     case N_Unchecked_Type_Conversion:
3215       gnu_result = gnat_to_gnu (Expression (gnat_node));
3216       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3217
3218       /* If the result is a pointer type, see if we are improperly
3219          converting to a stricter alignment.  */
3220
3221       if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
3222           && IN (Ekind (Etype (gnat_node)), Access_Kind))
3223         {
3224           unsigned int align = known_alignment (gnu_result);
3225           tree gnu_obj_type = TREE_TYPE (gnu_result_type);
3226           unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
3227
3228           if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
3229             post_error_ne_tree_2
3230               ("?source alignment (^) '< alignment of & (^)",
3231                gnat_node, Designated_Type (Etype (gnat_node)),
3232                size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
3233         }
3234
3235       gnu_result = unchecked_convert (gnu_result_type, gnu_result,
3236                                       No_Truncation (gnat_node));
3237       break;
3238
3239     case N_In:
3240     case N_Not_In:
3241       {
3242         tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
3243         Node_Id gnat_range = Right_Opnd (gnat_node);
3244         tree gnu_low;
3245         tree gnu_high;
3246
3247         /* GNAT_RANGE is either an N_Range node or an identifier
3248            denoting a subtype.  */
3249         if (Nkind (gnat_range) == N_Range)
3250           {
3251             gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
3252             gnu_high = gnat_to_gnu (High_Bound (gnat_range));
3253           }
3254         else if (Nkind (gnat_range) == N_Identifier
3255               || Nkind (gnat_range) == N_Expanded_Name)
3256           {
3257             tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
3258
3259             gnu_low = TYPE_MIN_VALUE (gnu_range_type);
3260             gnu_high = TYPE_MAX_VALUE (gnu_range_type);
3261           }
3262         else
3263           gcc_unreachable ();
3264
3265         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3266
3267         /* If LOW and HIGH are identical, perform an equality test.
3268            Otherwise, ensure that GNU_OBJECT is only evaluated once
3269            and perform a full range test.  */
3270         if (operand_equal_p (gnu_low, gnu_high, 0))
3271           gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
3272                                         gnu_object, gnu_low);
3273         else
3274           {
3275             gnu_object = protect_multiple_eval (gnu_object);
3276             gnu_result
3277               = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
3278                                  build_binary_op (GE_EXPR, gnu_result_type,
3279                                                   gnu_object, gnu_low),
3280                                  build_binary_op (LE_EXPR, gnu_result_type,
3281                                                   gnu_object, gnu_high));
3282           }
3283
3284         if (Nkind (gnat_node) == N_Not_In)
3285           gnu_result = invert_truthvalue (gnu_result);
3286       }
3287       break;
3288
3289     case N_Op_Divide:
3290       gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3291       gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3292       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3293       gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
3294                                     ? RDIV_EXPR
3295                                     : (Rounded_Result (gnat_node)
3296                                        ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
3297                                     gnu_result_type, gnu_lhs, gnu_rhs);
3298       break;
3299
3300     case N_Op_Or:    case N_Op_And:      case N_Op_Xor:
3301       /* These can either be operations on booleans or on modular types.
3302          Fall through for boolean types since that's the way GNU_CODES is
3303          set up.  */
3304       if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
3305               Modular_Integer_Kind))
3306         {
3307           enum tree_code code
3308             = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
3309                : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
3310                : BIT_XOR_EXPR);
3311
3312           gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3313           gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3314           gnu_result_type = get_unpadded_type (Etype (gnat_node));
3315           gnu_result = build_binary_op (code, gnu_result_type,
3316                                         gnu_lhs, gnu_rhs);
3317           break;
3318         }
3319
3320       /* ... fall through ... */
3321
3322     case N_Op_Eq:    case N_Op_Ne:       case N_Op_Lt:
3323     case N_Op_Le:    case N_Op_Gt:       case N_Op_Ge:
3324     case N_Op_Add:   case N_Op_Subtract: case N_Op_Multiply:
3325     case N_Op_Mod:   case N_Op_Rem:
3326     case N_Op_Rotate_Left:
3327     case N_Op_Rotate_Right:
3328     case N_Op_Shift_Left:
3329     case N_Op_Shift_Right:
3330     case N_Op_Shift_Right_Arithmetic:
3331     case N_And_Then: case N_Or_Else:
3332       {
3333         enum tree_code code = gnu_codes[Nkind (gnat_node)];
3334         tree gnu_type;
3335
3336         gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3337         gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3338         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3339
3340         /* If this is a comparison operator, convert any references to
3341            an unconstrained array value into a reference to the
3342            actual array.  */
3343         if (TREE_CODE_CLASS (code) == tcc_comparison)
3344           {
3345             gnu_lhs = maybe_unconstrained_array (gnu_lhs);
3346             gnu_rhs = maybe_unconstrained_array (gnu_rhs);
3347           }
3348
3349         /* If the result type is a private type, its full view may be a
3350            numeric subtype. The representation we need is that of its base
3351            type, given that it is the result of an arithmetic operation.  */
3352         else if (Is_Private_Type (Etype (gnat_node)))
3353           gnu_type = gnu_result_type
3354             = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
3355
3356         /* If this is a shift whose count is not guaranteed to be correct,
3357            we need to adjust the shift count.  */
3358         if (IN (Nkind (gnat_node), N_Op_Shift)
3359             && !Shift_Count_OK (gnat_node))
3360           {
3361             tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
3362             tree gnu_max_shift
3363               = convert (gnu_count_type, TYPE_SIZE (gnu_type));
3364
3365             if (Nkind (gnat_node) == N_Op_Rotate_Left
3366                 || Nkind (gnat_node) == N_Op_Rotate_Right)
3367               gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
3368                                          gnu_rhs, gnu_max_shift);
3369             else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
3370               gnu_rhs
3371                 = build_binary_op
3372                   (MIN_EXPR, gnu_count_type,
3373                    build_binary_op (MINUS_EXPR,
3374                                     gnu_count_type,
3375                                     gnu_max_shift,
3376                                     convert (gnu_count_type,
3377                                              integer_one_node)),
3378                    gnu_rhs);
3379           }
3380
3381         /* For right shifts, the type says what kind of shift to do,
3382            so we may need to choose a different type.  */
3383         if (Nkind (gnat_node) == N_Op_Shift_Right
3384             && !TYPE_UNSIGNED (gnu_type))
3385           gnu_type = gnat_unsigned_type (gnu_type);
3386         else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
3387                  && TYPE_UNSIGNED (gnu_type))
3388           gnu_type = gnat_signed_type (gnu_type);
3389
3390         if (gnu_type != gnu_result_type)
3391           {
3392             gnu_lhs = convert (gnu_type, gnu_lhs);
3393             gnu_rhs = convert (gnu_type, gnu_rhs);
3394           }
3395
3396         gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
3397
3398         /* If this is a logical shift with the shift count not verified,
3399            we must return zero if it is too large.  We cannot compensate
3400            above in this case.  */
3401         if ((Nkind (gnat_node) == N_Op_Shift_Left
3402              || Nkind (gnat_node) == N_Op_Shift_Right)
3403             && !Shift_Count_OK (gnat_node))
3404           gnu_result
3405             = build_cond_expr
3406               (gnu_type,
3407                build_binary_op (GE_EXPR, integer_type_node,
3408                                 gnu_rhs,
3409                                 convert (TREE_TYPE (gnu_rhs),
3410                                          TYPE_SIZE (gnu_type))),
3411                convert (gnu_type, integer_zero_node),
3412                gnu_result);
3413       }
3414       break;
3415
3416     case N_Conditional_Expression:
3417       {
3418         tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
3419         tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
3420         tree gnu_false
3421           = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
3422
3423         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3424         gnu_result = build_cond_expr (gnu_result_type,
3425                                       gnat_truthvalue_conversion (gnu_cond),
3426                                       gnu_true, gnu_false);
3427       }
3428       break;
3429
3430     case N_Op_Plus:
3431       gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
3432       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3433       break;
3434
3435     case N_Op_Not:
3436       /* This case can apply to a boolean or a modular type.
3437          Fall through for a boolean operand since GNU_CODES is set
3438          up to handle this.  */
3439       if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
3440         {
3441           gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
3442           gnu_result_type = get_unpadded_type (Etype (gnat_node));
3443           gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
3444                                        gnu_expr);
3445           break;
3446         }
3447
3448       /* ... fall through ... */
3449
3450     case N_Op_Minus:  case N_Op_Abs:
3451       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
3452
3453       if (Ekind (Etype (gnat_node)) != E_Private_Type)
3454          gnu_result_type = get_unpadded_type (Etype (gnat_node));
3455       else
3456          gnu_result_type = get_unpadded_type (Base_Type
3457                                               (Full_View (Etype (gnat_node))));
3458
3459       gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
3460                                    gnu_result_type, gnu_expr);
3461       break;
3462
3463     case N_Allocator:
3464       {
3465         tree gnu_init = 0;
3466         tree gnu_type;
3467         bool ignore_init_type = false;
3468
3469         gnat_temp = Expression (gnat_node);
3470
3471         /* The Expression operand can either be an N_Identifier or
3472            Expanded_Name, which must represent a type, or a
3473            N_Qualified_Expression, which contains both the object type and an
3474            initial value for the object.  */
3475         if (Nkind (gnat_temp) == N_Identifier
3476             || Nkind (gnat_temp) == N_Expanded_Name)
3477           gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
3478         else if (Nkind (gnat_temp) == N_Qualified_Expression)
3479           {
3480             Entity_Id gnat_desig_type
3481               = Designated_Type (Underlying_Type (Etype (gnat_node)));
3482
3483             ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
3484             gnu_init = gnat_to_gnu (Expression (gnat_temp));
3485
3486             gnu_init = maybe_unconstrained_array (gnu_init);
3487             if (Do_Range_Check (Expression (gnat_temp)))
3488               gnu_init = emit_range_check (gnu_init, gnat_desig_type);
3489
3490             if (Is_Elementary_Type (gnat_desig_type)
3491                 || Is_Constrained (gnat_desig_type))
3492               {
3493                 gnu_type = gnat_to_gnu_type (gnat_desig_type);
3494                 gnu_init = convert (gnu_type, gnu_init);
3495               }
3496             else
3497               {
3498                 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
3499                 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
3500                   gnu_type = TREE_TYPE (gnu_init);
3501
3502                 gnu_init = convert (gnu_type, gnu_init);
3503               }
3504           }
3505         else
3506           gcc_unreachable ();
3507
3508         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3509         return build_allocator (gnu_type, gnu_init, gnu_result_type,
3510                                 Procedure_To_Call (gnat_node),
3511                                 Storage_Pool (gnat_node), gnat_node,
3512                                 ignore_init_type);
3513       }
3514       break;
3515
3516     /***************************/
3517     /* Chapter 5: Statements:  */
3518     /***************************/
3519
3520     case N_Label:
3521       gnu_result = build1 (LABEL_EXPR, void_type_node,
3522                            gnat_to_gnu (Identifier (gnat_node)));
3523       break;
3524
3525     case N_Null_Statement:
3526       gnu_result = alloc_stmt_list ();
3527       break;
3528
3529     case N_Assignment_Statement:
3530       /* Get the LHS and RHS of the statement and convert any reference to an
3531          unconstrained array into a reference to the underlying array.
3532          If we are not to do range checking and the RHS is an N_Function_Call,
3533          pass the LHS to the call function.  */
3534       gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
3535
3536       /* If the type has a size that overflows, convert this into raise of
3537          Storage_Error: execution shouldn't have gotten here anyway.  */
3538       if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
3539            && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
3540         gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node);
3541       else if (Nkind (Expression (gnat_node)) == N_Function_Call
3542                && !Do_Range_Check (Expression (gnat_node)))
3543         gnu_result = call_to_gnu (Expression (gnat_node),
3544                                   &gnu_result_type, gnu_lhs);
3545       else
3546         {
3547           gnu_rhs
3548             = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
3549
3550           /* If range check is needed, emit code to generate it */
3551           if (Do_Range_Check (Expression (gnat_node)))
3552             gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
3553
3554           gnu_result
3555             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
3556         }
3557       break;
3558
3559     case N_If_Statement:
3560       {
3561         tree *gnu_else_ptr;     /* Point to put next "else if" or "else". */
3562
3563         /* Make the outer COND_EXPR.  Avoid non-determinism.  */
3564         gnu_result = build3 (COND_EXPR, void_type_node,
3565                              gnat_to_gnu (Condition (gnat_node)),
3566                              NULL_TREE, NULL_TREE);
3567         COND_EXPR_THEN (gnu_result)
3568           = build_stmt_group (Then_Statements (gnat_node), false);
3569         TREE_SIDE_EFFECTS (gnu_result) = 1;
3570         gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
3571
3572         /* Now make a COND_EXPR for each of the "else if" parts.  Put each
3573            into the previous "else" part and point to where to put any
3574            outer "else".  Also avoid non-determinism.  */
3575         if (Present (Elsif_Parts (gnat_node)))
3576           for (gnat_temp = First (Elsif_Parts (gnat_node));
3577                Present (gnat_temp); gnat_temp = Next (gnat_temp))
3578             {
3579               gnu_expr = build3 (COND_EXPR, void_type_node,
3580                                  gnat_to_gnu (Condition (gnat_temp)),
3581                                  NULL_TREE, NULL_TREE);
3582               COND_EXPR_THEN (gnu_expr)
3583                 = build_stmt_group (Then_Statements (gnat_temp), false);
3584               TREE_SIDE_EFFECTS (gnu_expr) = 1;
3585               annotate_with_node (gnu_expr, gnat_temp);
3586               *gnu_else_ptr = gnu_expr;
3587               gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3588             }
3589
3590         *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
3591       }
3592       break;
3593
3594     case N_Case_Statement:
3595       gnu_result = Case_Statement_to_gnu (gnat_node);
3596       break;
3597
3598     case N_Loop_Statement:
3599       gnu_result = Loop_Statement_to_gnu (gnat_node);
3600       break;
3601
3602     case N_Block_Statement:
3603       start_stmt_group ();
3604       gnat_pushlevel ();
3605       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3606       add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3607       gnat_poplevel ();
3608       gnu_result = end_stmt_group ();
3609
3610       if (Present (Identifier (gnat_node)))
3611         mark_out_of_scope (Entity (Identifier (gnat_node)));
3612       break;
3613
3614     case N_Exit_Statement:
3615       gnu_result
3616         = build2 (EXIT_STMT, void_type_node,
3617                   (Present (Condition (gnat_node))
3618                    ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
3619                   (Present (Name (gnat_node))
3620                    ? get_gnu_tree (Entity (Name (gnat_node)))
3621                    : TREE_VALUE (gnu_loop_label_stack)));
3622       break;
3623
3624     case N_Return_Statement:
3625       {
3626         /* The gnu function type of the subprogram currently processed.  */
3627         tree gnu_subprog_type = TREE_TYPE (current_function_decl);
3628         /* The return value from the subprogram.  */
3629         tree gnu_ret_val = NULL_TREE;
3630         /* The place to put the return value.  */
3631         tree gnu_lhs;
3632
3633         /* If we are dealing with a "return;" from an Ada procedure with
3634            parameters passed by copy in copy out, we need to return a record
3635            containing the final values of these parameters.  If the list
3636            contains only one entry, return just that entry.
3637
3638            For a full description of the copy in copy out parameter mechanism,
3639            see the part of the gnat_to_gnu_entity routine dealing with the
3640            translation of subprograms.
3641
3642            But if we have a return label defined, convert this into
3643            a branch to that label.  */
3644
3645         if (TREE_VALUE (gnu_return_label_stack))
3646           {
3647             gnu_result = build1 (GOTO_EXPR, void_type_node,
3648                                  TREE_VALUE (gnu_return_label_stack));
3649             break;
3650           }
3651
3652         else if (TYPE_CI_CO_LIST (gnu_subprog_type))
3653           {
3654             gnu_lhs = DECL_RESULT (current_function_decl);
3655             if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
3656               gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
3657             else
3658               gnu_ret_val
3659                 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
3660                                           TYPE_CI_CO_LIST (gnu_subprog_type));
3661           }
3662
3663         /* If the Ada subprogram is a function, we just need to return the
3664            expression.   If the subprogram returns an unconstrained
3665            array, we have to allocate a new version of the result and
3666            return it.  If we return by reference, return a pointer.  */
3667
3668         else if (Present (Expression (gnat_node)))
3669           {
3670             /* If the current function returns by target pointer and we
3671                are doing a call, pass that target to the call.  */
3672             if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
3673                 && Nkind (Expression (gnat_node)) == N_Function_Call)
3674               {
3675                 gnu_lhs
3676                   = build_unary_op (INDIRECT_REF, NULL_TREE,
3677                                     DECL_ARGUMENTS (current_function_decl));
3678                 gnu_result = call_to_gnu (Expression (gnat_node),
3679                                           &gnu_result_type, gnu_lhs);
3680               }
3681             else
3682               {
3683                 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
3684
3685                 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
3686                   /* The original return type was unconstrained so dereference
3687                      the TARGET pointer in the actual return value's type. */
3688                   gnu_lhs
3689                     = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
3690                                       DECL_ARGUMENTS (current_function_decl));
3691                 else
3692                   gnu_lhs = DECL_RESULT (current_function_decl);
3693
3694                 /* Do not remove the padding from GNU_RET_VAL if the inner
3695                    type is self-referential since we want to allocate the fixed
3696                    size in that case.  */
3697                 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
3698                     && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
3699                         == RECORD_TYPE)
3700                     && (TYPE_IS_PADDING_P
3701                         (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
3702                     && (CONTAINS_PLACEHOLDER_P
3703                         (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
3704                   gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
3705
3706                 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
3707                     || By_Ref (gnat_node))
3708                   gnu_ret_val
3709                     = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
3710
3711                 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
3712                   {
3713                     gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
3714
3715                     /* We have two cases: either the function returns with
3716                        depressed stack or not.  If not, we allocate on the
3717                        secondary stack.  If so, we allocate in the stack frame.
3718                        if no copy is needed, the front end will set By_Ref,
3719                        which we handle in the case above.  */
3720                     if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
3721                       gnu_ret_val
3722                         = build_allocator (TREE_TYPE (gnu_ret_val),
3723                                            gnu_ret_val,
3724                                            TREE_TYPE (gnu_subprog_type),
3725                                            0, -1, gnat_node, false);
3726                     else
3727                       gnu_ret_val
3728                         = build_allocator (TREE_TYPE (gnu_ret_val),
3729                                            gnu_ret_val,
3730                                            TREE_TYPE (gnu_subprog_type),
3731                                            Procedure_To_Call (gnat_node),
3732                                            Storage_Pool (gnat_node),
3733                                            gnat_node, false);
3734                   }
3735               }
3736           }
3737         else
3738           /* If the Ada subprogram is a regular procedure, just return.  */
3739           gnu_lhs = NULL_TREE;
3740
3741         if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
3742           {
3743             if (gnu_ret_val)
3744               gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3745                                             gnu_lhs, gnu_ret_val);
3746             add_stmt_with_node (gnu_result, gnat_node);
3747             gnu_lhs = NULL_TREE;
3748           }
3749
3750         gnu_result = build_return_expr (gnu_lhs, gnu_ret_val);
3751       }
3752       break;
3753
3754     case N_Goto_Statement:
3755       gnu_result = build1 (GOTO_EXPR, void_type_node,
3756                            gnat_to_gnu (Name (gnat_node)));
3757       break;
3758
3759     /****************************/
3760     /* Chapter 6: Subprograms:  */
3761     /****************************/
3762
3763     case N_Subprogram_Declaration:
3764       /* Unless there is a freeze node, declare the subprogram.  We consider
3765          this a "definition" even though we're not generating code for
3766          the subprogram because we will be making the corresponding GCC
3767          node here.  */
3768
3769       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
3770         gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
3771                             NULL_TREE, 1);
3772       gnu_result = alloc_stmt_list ();
3773       break;
3774
3775     case N_Abstract_Subprogram_Declaration:
3776       /* This subprogram doesn't exist for code generation purposes, but we
3777          have to elaborate the types of any parameters, unless they are
3778          imported types (nothing to generate in this case).  */
3779       for (gnat_temp
3780            = First_Formal (Defining_Entity (Specification (gnat_node)));
3781            Present (gnat_temp);
3782            gnat_temp = Next_Formal_With_Extras (gnat_temp))
3783         if (Is_Itype (Etype (gnat_temp))
3784             && !From_With_Type (Etype (gnat_temp)))
3785           gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3786
3787       gnu_result = alloc_stmt_list ();
3788       break;
3789
3790     case N_Defining_Program_Unit_Name:
3791       /* For a child unit identifier go up a level to get the
3792          specification.  We get this when we try to find the spec of
3793          a child unit package that is the compilation unit being compiled. */
3794       gnu_result = gnat_to_gnu (Parent (gnat_node));
3795       break;
3796
3797     case N_Subprogram_Body:
3798       Subprogram_Body_to_gnu (gnat_node);
3799       gnu_result = alloc_stmt_list ();
3800       break;
3801
3802     case N_Function_Call:
3803     case N_Procedure_Call_Statement:
3804       gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
3805       break;
3806
3807     /*************************/
3808     /* Chapter 7: Packages:  */
3809     /*************************/
3810
3811     case N_Package_Declaration:
3812       gnu_result = gnat_to_gnu (Specification (gnat_node));
3813       break;
3814
3815     case N_Package_Specification:
3816
3817       start_stmt_group ();
3818       process_decls (Visible_Declarations (gnat_node),
3819                      Private_Declarations (gnat_node), Empty, true, true);
3820       gnu_result = end_stmt_group ();
3821       break;
3822
3823     case N_Package_Body:
3824
3825       /* If this is the body of a generic package - do nothing */
3826       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
3827         {
3828           gnu_result = alloc_stmt_list ();
3829           break;
3830         }
3831
3832       start_stmt_group ();
3833       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3834
3835       if (Present (Handled_Statement_Sequence (gnat_node)))
3836         add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3837
3838       gnu_result = end_stmt_group ();
3839       break;
3840
3841     /*********************************/
3842     /* Chapter 8: Visibility Rules:  */
3843     /*********************************/
3844
3845     case N_Use_Package_Clause:
3846     case N_Use_Type_Clause:
3847       /* Nothing to do here - but these may appear in list of declarations */
3848       gnu_result = alloc_stmt_list ();
3849       break;
3850
3851     /***********************/
3852     /* Chapter 9: Tasks:   */
3853     /***********************/
3854
3855     case N_Protected_Type_Declaration:
3856       gnu_result = alloc_stmt_list ();
3857       break;
3858
3859     case N_Single_Task_Declaration:
3860       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3861       gnu_result = alloc_stmt_list ();
3862       break;
3863
3864     /***********************************************************/
3865     /* Chapter 10: Program Structure and Compilation Issues:   */
3866     /***********************************************************/
3867
3868     case N_Compilation_Unit:
3869
3870       /* This is not called for the main unit, which is handled in function
3871          gigi above.  */
3872       start_stmt_group ();
3873       gnat_pushlevel ();
3874
3875       Compilation_Unit_to_gnu (gnat_node);
3876       gnu_result = alloc_stmt_list ();
3877       break;
3878
3879     case N_Subprogram_Body_Stub:
3880     case N_Package_Body_Stub:
3881     case N_Protected_Body_Stub:
3882     case N_Task_Body_Stub:
3883       /* Simply process whatever unit is being inserted.  */
3884       gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
3885       break;
3886
3887     case N_Subunit:
3888       gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
3889       break;
3890
3891     /***************************/
3892     /* Chapter 11: Exceptions: */
3893     /***************************/
3894
3895     case N_Handled_Sequence_Of_Statements:
3896       /* If there is an At_End procedure attached to this node, and the EH
3897          mechanism is SJLJ, we must have at least a corresponding At_End
3898          handler, unless the No_Exception_Handlers restriction is set.  */
3899       gcc_assert (type_annotate_only
3900                   || Exception_Mechanism != Setjmp_Longjmp
3901                   || No (At_End_Proc (gnat_node))
3902                   || Present (Exception_Handlers (gnat_node))
3903                   || No_Exception_Handlers_Set ());
3904
3905       gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
3906       break;
3907
3908     case N_Exception_Handler:
3909       if (Exception_Mechanism == Setjmp_Longjmp)
3910         gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
3911       else if (Exception_Mechanism == Back_End_Exceptions)
3912         gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
3913       else
3914         gcc_unreachable ();
3915
3916       break;
3917
3918     /*******************************/
3919     /* Chapter 12: Generic Units:  */
3920     /*******************************/
3921
3922     case N_Generic_Function_Renaming_Declaration:
3923     case N_Generic_Package_Renaming_Declaration:
3924     case N_Generic_Procedure_Renaming_Declaration:
3925     case N_Generic_Package_Declaration:
3926     case N_Generic_Subprogram_Declaration:
3927     case N_Package_Instantiation:
3928     case N_Procedure_Instantiation:
3929     case N_Function_Instantiation:
3930       /* These nodes can appear on a declaration list but there is nothing to
3931          to be done with them.  */
3932       gnu_result = alloc_stmt_list ();
3933       break;
3934
3935     /***************************************************/
3936     /* Chapter 13: Representation Clauses and          */
3937     /*             Implementation-Dependent Features:  */
3938     /***************************************************/
3939
3940     case N_Attribute_Definition_Clause:
3941
3942       gnu_result = alloc_stmt_list ();
3943
3944       /* The only one we need deal with is for 'Address.  For the others, SEM
3945          puts the information elsewhere.  We need only deal with 'Address
3946          if the object has a Freeze_Node (which it never will currently).  */
3947       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
3948           || No (Freeze_Node (Entity (Name (gnat_node)))))
3949         break;
3950
3951       /* Get the value to use as the address and save it as the
3952          equivalent for GNAT_TEMP.  When the object is frozen,
3953          gnat_to_gnu_entity will do the right thing. */
3954       save_gnu_tree (Entity (Name (gnat_node)),
3955                      gnat_to_gnu (Expression (gnat_node)), true);
3956       break;
3957
3958     case N_Enumeration_Representation_Clause:
3959     case N_Record_Representation_Clause:
3960     case N_At_Clause:
3961       /* We do nothing with these.  SEM puts the information elsewhere.  */
3962       gnu_result = alloc_stmt_list ();
3963       break;
3964
3965     case N_Code_Statement:
3966       if (!type_annotate_only)
3967         {
3968           tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
3969           tree gnu_input_list = NULL_TREE, gnu_output_list = NULL_TREE;
3970           tree gnu_clobber_list = NULL_TREE;
3971           char *clobber;
3972
3973           /* First process inputs, then outputs, then clobbers.  */
3974           Setup_Asm_Inputs (gnat_node);
3975           while (Present (gnat_temp = Asm_Input_Value ()))
3976             {
3977               tree gnu_value = gnat_to_gnu (gnat_temp);
3978               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3979                                                  (Asm_Input_Constraint ()));
3980
3981               gnu_input_list
3982                 = tree_cons (gnu_constr, gnu_value, gnu_input_list);
3983               Next_Asm_Input ();
3984             }
3985
3986           Setup_Asm_Outputs (gnat_node);
3987           while (Present (gnat_temp = Asm_Output_Variable ()))
3988             {
3989               tree gnu_value = gnat_to_gnu (gnat_temp);
3990               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3991                                                  (Asm_Output_Constraint ()));
3992
3993               gnu_output_list
3994                 = tree_cons (gnu_constr, gnu_value, gnu_output_list);
3995               Next_Asm_Output ();
3996             }
3997
3998           Clobber_Setup (gnat_node);
3999           while ((clobber = Clobber_Get_Next ()))
4000             gnu_clobber_list
4001               = tree_cons (NULL_TREE,
4002                            build_string (strlen (clobber) + 1, clobber),
4003                            gnu_clobber_list);
4004
4005           gnu_input_list = nreverse (gnu_input_list);
4006           gnu_output_list = nreverse (gnu_output_list);
4007           gnu_result = build4 (ASM_EXPR,  void_type_node,
4008                                gnu_template, gnu_output_list,
4009                                gnu_input_list, gnu_clobber_list);
4010           ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
4011         }
4012       else
4013         gnu_result = alloc_stmt_list ();
4014
4015       break;
4016
4017     /***************************************************/
4018     /* Added Nodes                                     */
4019     /***************************************************/
4020
4021     case N_Freeze_Entity:
4022       start_stmt_group ();
4023       process_freeze_entity (gnat_node);
4024       process_decls (Actions (gnat_node), Empty, Empty, true, true);
4025       gnu_result = end_stmt_group ();
4026       break;
4027
4028     case N_Itype_Reference:
4029       if (!present_gnu_tree (Itype (gnat_node)))
4030         process_type (Itype (gnat_node));
4031
4032       gnu_result = alloc_stmt_list ();
4033       break;
4034
4035     case N_Free_Statement:
4036       if (!type_annotate_only)
4037         {
4038           tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
4039           tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
4040           tree gnu_obj_type;
4041           tree gnu_actual_obj_type = 0;
4042           tree gnu_obj_size;
4043           int align;
4044
4045           /* If this is a thin pointer, we must dereference it to create
4046              a fat pointer, then go back below to a thin pointer.  The
4047              reason for this is that we need a fat pointer someplace in
4048              order to properly compute the size.  */
4049           if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
4050             gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
4051                                       build_unary_op (INDIRECT_REF, NULL_TREE,
4052                                                       gnu_ptr));
4053
4054           /* If this is an unconstrained array, we know the object must
4055              have been allocated with the template in front of the object.
4056              So pass the template address, but get the total size.  Do this
4057              by converting to a thin pointer.  */
4058           if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
4059             gnu_ptr
4060               = convert (build_pointer_type
4061                          (TYPE_OBJECT_RECORD_TYPE
4062                           (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
4063                          gnu_ptr);
4064
4065           gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
4066
4067           if (Present (Actual_Designated_Subtype (gnat_node)))
4068             {
4069               gnu_actual_obj_type
4070                 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
4071
4072               if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
4073                 gnu_actual_obj_type
4074                   = build_unc_object_type_from_ptr (gnu_ptr_type,
4075                       gnu_actual_obj_type,
4076                       get_identifier ("DEALLOC"));
4077             }
4078           else
4079             gnu_actual_obj_type = gnu_obj_type;
4080
4081           gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
4082           align = TYPE_ALIGN (gnu_obj_type);
4083
4084           if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
4085               && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
4086             {
4087               tree gnu_char_ptr_type = build_pointer_type (char_type_node);
4088               tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
4089               tree gnu_byte_offset
4090                 = convert (gnu_char_ptr_type,
4091                            size_diffop (size_zero_node, gnu_pos));
4092
4093               gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
4094               gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
4095                                          gnu_ptr, gnu_byte_offset);
4096             }
4097
4098           gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
4099                                                  Procedure_To_Call (gnat_node),
4100                                                  Storage_Pool (gnat_node),
4101                                                  gnat_node);
4102         }
4103       break;
4104
4105     case N_Raise_Constraint_Error:
4106     case N_Raise_Program_Error:
4107     case N_Raise_Storage_Error:
4108       if (type_annotate_only)
4109         {
4110           gnu_result = alloc_stmt_list ();
4111           break;
4112         }
4113
4114       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4115       gnu_result
4116         = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node);
4117
4118       /* If the type is VOID, this is a statement, so we need to
4119          generate the code for the call.  Handle a Condition, if there
4120          is one.  */
4121       if (TREE_CODE (gnu_result_type) == VOID_TYPE)
4122         {
4123           annotate_with_node (gnu_result, gnat_node);
4124
4125           if (Present (Condition (gnat_node)))
4126             gnu_result = build3 (COND_EXPR, void_type_node,
4127                                  gnat_to_gnu (Condition (gnat_node)),
4128                                  gnu_result, alloc_stmt_list ());
4129         }
4130       else
4131         gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
4132       break;
4133
4134     case N_Validate_Unchecked_Conversion:
4135       /* If the result is a pointer type, see if we are either converting
4136          from a non-pointer or from a pointer to a type with a different
4137          alias set and warn if so.  If the result defined in the same unit as
4138          this unchecked conversion, we can allow this because we can know to
4139          make that type have alias set 0.  */
4140       {
4141         tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
4142         tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
4143
4144         if (POINTER_TYPE_P (gnu_target_type)
4145             && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node)
4146             && get_alias_set (TREE_TYPE (gnu_target_type)) != 0
4147             && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node)))
4148             && (!POINTER_TYPE_P (gnu_source_type)
4149                 || (get_alias_set (TREE_TYPE (gnu_source_type))
4150                     != get_alias_set (TREE_TYPE (gnu_target_type)))))
4151           {
4152             post_error_ne
4153               ("?possible aliasing problem for type&",
4154                gnat_node, Target_Type (gnat_node));
4155             post_error
4156               ("\\?use -fno-strict-aliasing switch for references",
4157                gnat_node);
4158             post_error_ne
4159               ("\\?or use `pragma No_Strict_Aliasing (&);`",
4160                gnat_node, Target_Type (gnat_node));
4161           }
4162
4163         /* The No_Strict_Aliasing flag is not propagated to the back-end for
4164            fat pointers so unconditionally warn in problematic cases.  */
4165         else if (TYPE_FAT_POINTER_P (gnu_target_type))
4166           {
4167             tree array_type
4168               = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
4169
4170             if (get_alias_set (array_type) != 0
4171                 && (!TYPE_FAT_POINTER_P (gnu_source_type)
4172                     || (get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))))
4173                         != get_alias_set (array_type))))
4174               {
4175                 post_error_ne
4176                   ("?possible aliasing problem for type&",
4177                    gnat_node, Target_Type (gnat_node));
4178                 post_error
4179                   ("\\?use -fno-strict-aliasing switch for references",
4180                    gnat_node);
4181               }
4182           }
4183       }
4184       gnu_result = alloc_stmt_list ();
4185       break;
4186
4187     case N_Raise_Statement:
4188     case N_Function_Specification:
4189     case N_Procedure_Specification:
4190     case N_Op_Concat:
4191     case N_Component_Association:
4192     case N_Task_Body:
4193     default:
4194       gcc_assert (type_annotate_only);
4195       gnu_result = alloc_stmt_list ();
4196     }
4197
4198   /* If we pushed our level as part of processing the elaboration routine,
4199      pop it back now.  */
4200   if (went_into_elab_proc)
4201     {
4202       add_stmt (gnu_result);
4203       gnat_poplevel ();
4204       gnu_result = end_stmt_group ();
4205       current_function_decl = NULL_TREE;
4206     }
4207
4208   /* Set the location information into the result.  Note that we may have
4209      no result if we tried to build a CALL_EXPR node to a procedure with
4210      no side-effects and optimization is enabled.  */
4211   if (gnu_result && EXPR_P (gnu_result))
4212     annotate_with_node (gnu_result, gnat_node);
4213
4214   /* If we're supposed to return something of void_type, it means we have
4215      something we're elaborating for effect, so just return.  */
4216   if (TREE_CODE (gnu_result_type) == VOID_TYPE)
4217     return gnu_result;
4218
4219   /* If the result is a constant that overflows, raise constraint error.  */
4220   else if (TREE_CODE (gnu_result) == INTEGER_CST
4221       && TREE_CONSTANT_OVERFLOW (gnu_result))
4222     {
4223       post_error ("Constraint_Error will be raised at run-time?", gnat_node);
4224
4225       gnu_result
4226         = build1 (NULL_EXPR, gnu_result_type,
4227                   build_call_raise (CE_Overflow_Check_Failed, gnat_node));
4228     }
4229
4230   /* If our result has side-effects and is of an unconstrained type,
4231      make a SAVE_EXPR so that we can be sure it will only be referenced
4232      once.  Note we must do this before any conversions.  */
4233   if (TREE_SIDE_EFFECTS (gnu_result)
4234       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
4235           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
4236     gnu_result = gnat_stabilize_reference (gnu_result, false);
4237
4238   /* Now convert the result to the proper type.  If the type is void or if
4239      we have no result, return error_mark_node to show we have no result.
4240      If the type of the result is correct or if we have a label (which doesn't
4241      have any well-defined type), return our result.  Also don't do the
4242      conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4243      since those are the cases where the front end may have the type wrong due
4244      to "instantiating" the unconstrained record with discriminant values
4245      or if this is a FIELD_DECL.  If this is the Name of an assignment
4246      statement or a parameter of a procedure call, return what we have since
4247      the RHS has to be converted to our type there in that case, unless
4248      GNU_RESULT_TYPE has a simpler size.  Similarly, if the two types are
4249      record types with the same name, the expression type has integral mode,
4250      and GNU_RESULT_TYPE BLKmode, don't convert.  This will be the case when
4251      we are converting from a packable type to its actual type and we need
4252      those conversions to be NOPs in order for assignments into these types to
4253      work properly if the inner object is a bitfield and hence can't have
4254      its address taken.  Finally, don't convert integral types that are the
4255      operand of an unchecked conversion since we need to ignore those
4256      conversions (for 'Valid).  Otherwise, convert the result to the proper
4257      type.  */
4258
4259   if (Present (Parent (gnat_node))
4260       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
4261            && Name (Parent (gnat_node)) == gnat_node)
4262           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
4263               && Name (Parent (gnat_node)) != gnat_node)
4264           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
4265               && !AGGREGATE_TYPE_P (gnu_result_type)
4266               && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4267           || Nkind (Parent (gnat_node)) == N_Parameter_Association)
4268       && !(TYPE_SIZE (gnu_result_type)
4269            && TYPE_SIZE (TREE_TYPE (gnu_result))
4270            && (AGGREGATE_TYPE_P (gnu_result_type)
4271                == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4272            && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
4273                 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
4274                     != INTEGER_CST))
4275                || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4276                    && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
4277                    && (CONTAINS_PLACEHOLDER_P
4278                        (TYPE_SIZE (TREE_TYPE (gnu_result))))))
4279            && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
4280                 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
4281     {
4282       /* In this case remove padding only if the inner object is of
4283          self-referential size: in that case it must be an object of
4284          unconstrained type with a default discriminant.  In other cases,
4285          we want to avoid copying too much data.  */
4286       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4287           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
4288           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4289                                      (TREE_TYPE (TYPE_FIELDS
4290                                                  (TREE_TYPE (gnu_result))))))
4291         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4292                               gnu_result);
4293     }
4294
4295   else if (TREE_CODE (gnu_result) == LABEL_DECL
4296            || TREE_CODE (gnu_result) == FIELD_DECL
4297            || TREE_CODE (gnu_result) == ERROR_MARK
4298            || (TYPE_SIZE (gnu_result_type)
4299                && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4300                && TREE_CODE (gnu_result) != INDIRECT_REF
4301                && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
4302            || ((TYPE_NAME (gnu_result_type)
4303                 == TYPE_NAME (TREE_TYPE (gnu_result)))
4304                && TREE_CODE (gnu_result_type) == RECORD_TYPE
4305                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4306                && TYPE_MODE (gnu_result_type) == BLKmode
4307                && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
4308                    == MODE_INT)))
4309     {
4310       /* Remove any padding record, but do nothing more in this case.  */
4311       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4312           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4313         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4314                               gnu_result);
4315     }
4316
4317   else if (gnu_result == error_mark_node
4318            || gnu_result_type == void_type_node)
4319     gnu_result =  error_mark_node;
4320   else if (gnu_result_type != TREE_TYPE (gnu_result))
4321     gnu_result = convert (gnu_result_type, gnu_result);
4322
4323   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT.  */
4324   while ((TREE_CODE (gnu_result) == NOP_EXPR
4325           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
4326          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
4327     gnu_result = TREE_OPERAND (gnu_result, 0);
4328
4329   return gnu_result;
4330 }
4331 \f
4332 /* Record the current code position in GNAT_NODE.  */
4333
4334 static void
4335 record_code_position (Node_Id gnat_node)
4336 {
4337   tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
4338
4339   add_stmt_with_node (stmt_stmt, gnat_node);
4340   save_gnu_tree (gnat_node, stmt_stmt, true);
4341 }
4342
4343 /* Insert the code for GNAT_NODE at the position saved for that node.  */
4344
4345 static void
4346 insert_code_for (Node_Id gnat_node)
4347 {
4348   STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
4349   save_gnu_tree (gnat_node, NULL_TREE, true);
4350 }
4351 \f
4352 /* Start a new statement group chained to the previous group.  */
4353
4354 static void
4355 start_stmt_group ()
4356 {
4357   struct stmt_group *group = stmt_group_free_list;
4358
4359   /* First see if we can get one from the free list.  */
4360   if (group)
4361     stmt_group_free_list = group->previous;
4362   else
4363     group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group));
4364
4365   group->previous = current_stmt_group;
4366   group->stmt_list = group->block = group->cleanups = NULL_TREE;
4367   current_stmt_group = group;
4368 }
4369
4370 /* Add GNU_STMT to the current statement group.  */
4371
4372 void
4373 add_stmt (tree gnu_stmt)
4374 {
4375   append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
4376
4377   /* If we're at top level, show everything in here is in use in case
4378      any of it is shared by a subprogram.  */
4379   if (global_bindings_p ())
4380     walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
4381
4382 }
4383
4384 /* Similar, but set the location of GNU_STMT to that of GNAT_NODE.  */
4385
4386 void
4387 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
4388 {
4389   if (Present (gnat_node))
4390     annotate_with_node (gnu_stmt, gnat_node);
4391   add_stmt (gnu_stmt);
4392 }
4393
4394 /* Add a declaration statement for GNU_DECL to the current statement group.
4395    Get SLOC from Entity_Id.  */
4396
4397 void
4398 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
4399 {
4400   tree gnu_stmt;
4401
4402   /* If this is a variable that Gigi is to ignore, we may have been given
4403      an ERROR_MARK.  So test for it.  We also might have been given a
4404      reference for a renaming.  So only do something for a decl.  Also
4405      ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE.  */
4406   if (!DECL_P (gnu_decl)
4407       || (TREE_CODE (gnu_decl) == TYPE_DECL
4408           && TREE_CODE (TREE_TYPE (gnu_decl)) == UNCONSTRAINED_ARRAY_TYPE))
4409     return;
4410
4411   /* If we are global, we don't want to actually output the DECL_EXPR for
4412      this decl since we already have evaluated the expressions in the
4413      sizes and positions as globals and doing it again would be wrong.
4414      But we do have to mark everything as used.  */
4415   gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
4416   if (!global_bindings_p ())
4417     add_stmt_with_node (gnu_stmt, gnat_entity);
4418   else
4419     {
4420       walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
4421       if (TREE_CODE (gnu_decl) == VAR_DECL
4422           || TREE_CODE (gnu_decl) == CONST_DECL)
4423         {
4424           walk_tree (&DECL_SIZE (gnu_decl), mark_visited, NULL, NULL);
4425           walk_tree (&DECL_SIZE_UNIT (gnu_decl), mark_visited, NULL, NULL);
4426           walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL);
4427         }
4428     }
4429
4430   /* If this is a DECL_EXPR for a variable with DECL_INITIAL set,
4431      there are two cases we need to handle here.  */
4432   if (TREE_CODE (gnu_decl) == VAR_DECL && DECL_INITIAL (gnu_decl))
4433     {
4434       tree gnu_init = DECL_INITIAL (gnu_decl);
4435       tree gnu_lhs = NULL_TREE;
4436
4437       /* If this is a DECL_EXPR for a variable with DECL_INITIAL set
4438          and decl has a padded type, convert it to the unpadded type so the
4439          assignment is done properly.  */
4440       if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE
4441           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_decl)))
4442         gnu_lhs
4443           = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_decl))), gnu_decl);
4444
4445       /* Otherwise, if this is going into memory and the initializer isn't
4446          valid for the assembler and loader.  Gimplification could do this,
4447          but would be run too late if -fno-unit-at-a-time.  */
4448       else if (TREE_STATIC (gnu_decl)
4449                && !initializer_constant_valid_p (gnu_init,
4450                                                  TREE_TYPE (gnu_decl)))
4451         gnu_lhs = gnu_decl;
4452
4453       if (gnu_lhs)
4454         {
4455           tree gnu_assign_stmt
4456             = build_binary_op (MODIFY_EXPR, NULL_TREE,
4457                                gnu_lhs, DECL_INITIAL (gnu_decl));
4458
4459           DECL_INITIAL (gnu_decl) = 0;
4460           TREE_READONLY (gnu_decl) = 0;
4461           annotate_with_locus (gnu_assign_stmt,
4462                                DECL_SOURCE_LOCATION (gnu_decl));
4463           add_stmt (gnu_assign_stmt);
4464         }
4465     }
4466 }
4467
4468 /* Utility function to mark nodes with TREE_VISITED and types as having their
4469    sized gimplified.  Called from walk_tree.  We use this to indicate all
4470    variable sizes and positions in global types may not be shared by any
4471    subprogram.  */
4472
4473 static tree
4474 mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
4475 {
4476   if (TREE_VISITED (*tp))
4477     *walk_subtrees = 0;
4478
4479   /* Don't mark a dummy type as visited because we want to mark its sizes
4480      and fields once it's filled in.  */
4481   else if (!TYPE_IS_DUMMY_P (*tp))
4482     TREE_VISITED (*tp) = 1;
4483
4484   if (TYPE_P (*tp))
4485     TYPE_SIZES_GIMPLIFIED (*tp) = 1;
4486
4487   return NULL_TREE;
4488 }
4489
4490 /* Likewise, but to mark as unvisited.  */
4491
4492 static tree
4493 mark_unvisited (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
4494                 void *data ATTRIBUTE_UNUSED)
4495 {
4496   TREE_VISITED (*tp) = 0;
4497
4498   return NULL_TREE;
4499 }
4500
4501 /* Add GNU_CLEANUP, a cleanup action, to the current code group.  */
4502
4503 static void
4504 add_cleanup (tree gnu_cleanup)
4505 {
4506   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
4507 }
4508
4509 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
4510
4511 void
4512 set_block_for_group (tree gnu_block)
4513 {
4514   gcc_assert (!current_stmt_group->block);
4515   current_stmt_group->block = gnu_block;
4516 }
4517
4518 /* Return code corresponding to the current code group.  It is normally
4519    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
4520    BLOCK or cleanups were set.  */
4521
4522 static tree
4523 end_stmt_group ()
4524 {
4525   struct stmt_group *group = current_stmt_group;
4526   tree gnu_retval = group->stmt_list;
4527
4528   /* If this is a null list, allocate a new STATEMENT_LIST.  Then, if there
4529      are cleanups, make a TRY_FINALLY_EXPR.  Last, if there is a BLOCK,
4530      make a BIND_EXPR.  Note that we nest in that because the cleanup may
4531      reference variables in the block.  */
4532   if (gnu_retval == NULL_TREE)
4533     gnu_retval = alloc_stmt_list ();
4534
4535   if (group->cleanups)
4536     gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
4537                          group->cleanups);
4538
4539   if (current_stmt_group->block)
4540     gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
4541                          gnu_retval, group->block);
4542
4543   /* Remove this group from the stack and add it to the free list.  */
4544   current_stmt_group = group->previous;
4545   group->previous = stmt_group_free_list;
4546   stmt_group_free_list = group;
4547
4548   return gnu_retval;
4549 }
4550
4551 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
4552    statements.*/
4553
4554 static void
4555 add_stmt_list (List_Id gnat_list)
4556 {
4557   Node_Id gnat_node;
4558
4559   if (Present (gnat_list))
4560     for (gnat_node = First (gnat_list); Present (gnat_node);
4561          gnat_node = Next (gnat_node))
4562       add_stmt (gnat_to_gnu (gnat_node));
4563 }
4564
4565 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
4566    If BINDING_P is true, push and pop a binding level around the list.  */
4567
4568 static tree
4569 build_stmt_group (List_Id gnat_list, bool binding_p)
4570 {
4571   start_stmt_group ();
4572   if (binding_p)
4573     gnat_pushlevel ();
4574
4575   add_stmt_list (gnat_list);
4576   if (binding_p)
4577     gnat_poplevel ();
4578
4579   return end_stmt_group ();
4580 }
4581 \f
4582 /* Push and pop routines for stacks.  We keep a free list around so we
4583    don't waste tree nodes.  */
4584
4585 static void
4586 push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value)
4587 {
4588   tree gnu_node = gnu_stack_free_list;
4589
4590   if (gnu_node)
4591     {
4592       gnu_stack_free_list = TREE_CHAIN (gnu_node);
4593       TREE_CHAIN (gnu_node) = *gnu_stack_ptr;
4594       TREE_PURPOSE (gnu_node) = gnu_purpose;
4595       TREE_VALUE (gnu_node) = gnu_value;
4596     }
4597   else
4598     gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr);
4599
4600   *gnu_stack_ptr = gnu_node;
4601 }
4602
4603 static void
4604 pop_stack (tree *gnu_stack_ptr)
4605 {
4606   tree gnu_node = *gnu_stack_ptr;
4607
4608   *gnu_stack_ptr = TREE_CHAIN (gnu_node);
4609   TREE_CHAIN (gnu_node) = gnu_stack_free_list;
4610   gnu_stack_free_list = gnu_node;
4611 }
4612 \f
4613 /* GNU_STMT is a statement.  We generate code for that statement.  */
4614
4615 void
4616 gnat_expand_stmt (tree gnu_stmt)
4617 {
4618 #if 0
4619   tree gnu_elmt, gnu_elmt_2;
4620 #endif
4621
4622   switch (TREE_CODE (gnu_stmt))
4623     {
4624 #if 0
4625     case USE_STMT:
4626       /* First write a volatile ASM_INPUT to prevent anything from being
4627          moved.  */
4628       gnu_elmt = gen_rtx_ASM_INPUT (VOIDmode, "");
4629       MEM_VOLATILE_P (gnu_elmt) = 1;
4630       emit_insn (gnu_elmt);
4631
4632       gnu_elmt = expand_expr (TREE_OPERAND (gnu_stmt, 0), NULL_RTX, VOIDmode,
4633                             modifier);
4634       emit_insn (gen_rtx_USE (VOIDmode, ));
4635       return target;
4636 #endif
4637
4638     default:
4639       gcc_unreachable ();
4640     }
4641 }
4642 \f
4643 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
4644
4645 int
4646 gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED)
4647 {
4648   tree expr = *expr_p;
4649   tree op;
4650
4651   if (IS_ADA_STMT (expr))
4652     return gnat_gimplify_stmt (expr_p);
4653
4654   switch (TREE_CODE (expr))
4655     {
4656     case NULL_EXPR:
4657       /* If this is for a scalar, just make a VAR_DECL for it.  If for
4658          an aggregate, get a null pointer of the appropriate type and
4659          dereference it.  */
4660       if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
4661         *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
4662                           convert (build_pointer_type (TREE_TYPE (expr)),
4663                                    integer_zero_node));
4664       else
4665         {
4666           *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
4667           TREE_NO_WARNING (*expr_p) = 1;
4668         }
4669
4670       append_to_statement_list (TREE_OPERAND (expr, 0), pre_p);
4671       return GS_OK;
4672
4673     case UNCONSTRAINED_ARRAY_REF:
4674       /* We should only do this if we are just elaborating for side-effects,
4675          but we can't know that yet.  */
4676       *expr_p = TREE_OPERAND (*expr_p, 0);
4677       return GS_OK;
4678
4679     case ADDR_EXPR:
4680       op = TREE_OPERAND (expr, 0);
4681
4682       /* If we're taking the address of a constant CONSTRUCTOR, force it to
4683          be put into static memory.  We know it's going to be readonly given
4684          the semantics we have and it's required to be static memory in
4685          the case when the reference is in an elaboration procedure.   */
4686       if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
4687         {
4688           tree new_var = create_tmp_var (TREE_TYPE (op), "C");
4689
4690           TREE_READONLY (new_var) = 1;
4691           TREE_STATIC (new_var) = 1;
4692           TREE_ADDRESSABLE (new_var) = 1;
4693           DECL_INITIAL (new_var) = op;
4694
4695           TREE_OPERAND (expr, 0) = new_var;
4696           recompute_tree_invariant_for_addr_expr (expr);
4697           return GS_ALL_DONE;
4698         }
4699
4700       /* Otherwise, if we are taking the address of something that is neither
4701          reference, declaration, or constant, make a variable for the operand
4702          here and then take its address.  If we don't do it this way, we may
4703          confuse the gimplifier because it needs to know the variable is
4704          addressable at this point.  This duplicates code in
4705          internal_get_tmp_var, which is unfortunate.  */
4706       else if (TREE_CODE_CLASS (TREE_CODE (op)) != tcc_reference
4707                && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_declaration
4708                && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_constant)
4709         {
4710           tree new_var = create_tmp_var (TREE_TYPE (op), "A");
4711           tree mod = build2 (MODIFY_EXPR, TREE_TYPE (op), new_var, op);
4712
4713           TREE_ADDRESSABLE (new_var) = 1;
4714
4715           if (EXPR_HAS_LOCATION (op))
4716             SET_EXPR_LOCUS (mod, EXPR_LOCUS (op));
4717
4718           gimplify_and_add (mod, pre_p);
4719           TREE_OPERAND (expr, 0) = new_var;
4720           recompute_tree_invariant_for_addr_expr (expr);
4721           return GS_ALL_DONE;
4722         }
4723
4724       return GS_UNHANDLED;
4725
4726     case COMPONENT_REF:
4727       /* We have a kludge here.  If the FIELD_DECL is from a fat pointer and is
4728          from an early dummy type, replace it with the proper FIELD_DECL.  */
4729       if (TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (*expr_p, 0)))
4730           && DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1)))
4731         {
4732           TREE_OPERAND (*expr_p, 1)
4733             = DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1));
4734           return GS_OK;
4735         }
4736
4737       /* ... fall through ... */
4738
4739     default:
4740       return GS_UNHANDLED;
4741     }
4742 }
4743
4744 /* Generate GIMPLE in place for the statement at *STMT_P.  */
4745
4746 static enum gimplify_status
4747 gnat_gimplify_stmt (tree *stmt_p)
4748 {
4749   tree stmt = *stmt_p;
4750
4751   switch (TREE_CODE (stmt))
4752     {
4753     case STMT_STMT:
4754       *stmt_p = STMT_STMT_STMT (stmt);
4755       return GS_OK;
4756
4757     case USE_STMT:
4758       *stmt_p = NULL_TREE;
4759       return GS_ALL_DONE;
4760
4761     case LOOP_STMT:
4762       {
4763         tree gnu_start_label = create_artificial_label ();
4764         tree gnu_end_label = LOOP_STMT_LABEL (stmt);
4765
4766         /* Set to emit the statements of the loop.  */
4767         *stmt_p = NULL_TREE;
4768
4769         /* We first emit the start label and then a conditional jump to
4770            the end label if there's a top condition, then the body of the
4771            loop, then a conditional branch to the end label, then the update,
4772            if any, and finally a jump to the start label and the definition
4773            of the end label.  */
4774         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
4775                                           gnu_start_label),
4776                                   stmt_p);
4777
4778         if (LOOP_STMT_TOP_COND (stmt))
4779           append_to_statement_list (build3 (COND_EXPR, void_type_node,
4780                                             LOOP_STMT_TOP_COND (stmt),
4781                                             alloc_stmt_list (),
4782                                             build1 (GOTO_EXPR,
4783                                                     void_type_node,
4784                                                     gnu_end_label)),
4785                                     stmt_p);
4786
4787         append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
4788
4789         if (LOOP_STMT_BOT_COND (stmt))
4790           append_to_statement_list (build3 (COND_EXPR, void_type_node,
4791                                             LOOP_STMT_BOT_COND (stmt),
4792                                             alloc_stmt_list (),
4793                                             build1 (GOTO_EXPR,
4794                                                     void_type_node,
4795                                                     gnu_end_label)),
4796                                     stmt_p);
4797
4798         if (LOOP_STMT_UPDATE (stmt))
4799           append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p);
4800
4801         append_to_statement_list (build1 (GOTO_EXPR, void_type_node,
4802                                           gnu_start_label),
4803                                   stmt_p);
4804         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
4805                                           gnu_end_label),
4806                                   stmt_p);
4807         return GS_OK;
4808       }
4809
4810     case EXIT_STMT:
4811       /* Build a statement to jump to the corresponding end label, then
4812          see if it needs to be conditional.  */
4813       *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
4814       if (EXIT_STMT_COND (stmt))
4815         *stmt_p = build3 (COND_EXPR, void_type_node,
4816                           EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
4817       return GS_OK;
4818
4819     default:
4820       gcc_unreachable ();
4821     }
4822 }
4823 \f
4824 /* Force references to each of the entities in packages GNAT_NODE with's
4825    so that the debugging information for all of them are identical
4826    in all clients.  Operate recursively on anything it with's, but check
4827    that we aren't elaborating something more than once.  */
4828
4829 /* The reason for this routine's existence is two-fold.
4830    First, with some debugging formats, notably MDEBUG on SGI
4831    IRIX, the linker will remove duplicate debugging information if two
4832    clients have identical debugging information.  With the normal scheme
4833    of elaboration, this does not usually occur, since entities in with'ed
4834    packages are elaborated on demand, and if clients have different usage
4835    patterns, the normal case, then the order and selection of entities
4836    will differ.  In most cases however, it seems that linkers do not know
4837    how to eliminate duplicate debugging information, even if it is
4838    identical, so the use of this routine would increase the total amount
4839    of debugging information in the final executable.
4840
4841    Second, this routine is called in type_annotate mode, to compute DDA
4842    information for types in withed units, for ASIS use  */
4843
4844 static void
4845 elaborate_all_entities (Node_Id gnat_node)
4846 {
4847   Entity_Id gnat_with_clause, gnat_entity;
4848
4849   /* Process each unit only once. As we trace the context of all relevant
4850      units transitively, including generic bodies, we may encounter the
4851      same generic unit repeatedly */
4852
4853   if (!present_gnu_tree (gnat_node))
4854      save_gnu_tree (gnat_node, integer_zero_node, true);
4855
4856   /* Save entities in all context units. A body may have an implicit_with
4857      on its own spec, if the context includes a child unit, so don't save
4858      the spec twice.  */
4859
4860   for (gnat_with_clause = First (Context_Items (gnat_node));
4861        Present (gnat_with_clause);
4862        gnat_with_clause = Next (gnat_with_clause))
4863     if (Nkind (gnat_with_clause) == N_With_Clause
4864         && !present_gnu_tree (Library_Unit (gnat_with_clause))
4865         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
4866       {
4867         elaborate_all_entities (Library_Unit (gnat_with_clause));
4868
4869         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
4870           {
4871             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
4872                  Present (gnat_entity);
4873                  gnat_entity = Next_Entity (gnat_entity))
4874               if (Is_Public (gnat_entity)
4875                   && Convention (gnat_entity) != Convention_Intrinsic
4876                   && Ekind (gnat_entity) != E_Package
4877                   && Ekind (gnat_entity) != E_Package_Body
4878                   && Ekind (gnat_entity) != E_Operator
4879                   && !(IN (Ekind (gnat_entity), Type_Kind)
4880                        && !Is_Frozen (gnat_entity))
4881                   && !((Ekind (gnat_entity) == E_Procedure
4882                         || Ekind (gnat_entity) == E_Function)
4883                        && Is_Intrinsic_Subprogram (gnat_entity))
4884                   && !IN (Ekind (gnat_entity), Named_Kind)
4885                   && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
4886                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4887           }
4888         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
4889            {
4890             Node_Id gnat_body
4891               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
4892
4893             /* Retrieve compilation unit node of generic body.  */
4894             while (Present (gnat_body)
4895                    && Nkind (gnat_body) != N_Compilation_Unit)
4896               gnat_body = Parent (gnat_body);
4897
4898             /* If body is available, elaborate its context.  */
4899             if (Present (gnat_body))
4900                 elaborate_all_entities (gnat_body);
4901            }
4902       }
4903
4904   if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
4905     elaborate_all_entities (Library_Unit (gnat_node));
4906 }
4907 \f
4908 /* Do the processing of N_Freeze_Entity, GNAT_NODE.  */
4909
4910 static void
4911 process_freeze_entity (Node_Id gnat_node)
4912 {
4913   Entity_Id gnat_entity = Entity (gnat_node);
4914   tree gnu_old;
4915   tree gnu_new;
4916   tree gnu_init
4917     = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
4918        && present_gnu_tree (Declaration_Node (gnat_entity)))
4919       ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
4920
4921   /* If this is a package, need to generate code for the package.  */
4922   if (Ekind (gnat_entity) == E_Package)
4923     {
4924       insert_code_for
4925         (Parent (Corresponding_Body
4926                  (Parent (Declaration_Node (gnat_entity)))));
4927       return;
4928     }
4929
4930   /* Check for old definition after the above call.  This Freeze_Node
4931      might be for one its Itypes.  */
4932   gnu_old
4933     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4934
4935   /* If this entity has an Address representation clause, GNU_OLD is the
4936      address, so discard it here.  */
4937   if (Present (Address_Clause (gnat_entity)))
4938     gnu_old = 0;
4939
4940   /* Don't do anything for class-wide types they are always
4941      transformed into their root type.  */
4942   if (Ekind (gnat_entity) == E_Class_Wide_Type
4943       || (Ekind (gnat_entity) == E_Class_Wide_Subtype
4944           && Present (Equivalent_Type (gnat_entity))))
4945     return;
4946
4947   /* Don't do anything for subprograms that may have been elaborated before
4948      their freeze nodes.  This can happen, for example because of an inner call
4949      in an instance body, or a previous compilation of a spec for inlining
4950      purposes.  */
4951   if  ((gnu_old
4952         && TREE_CODE (gnu_old) == FUNCTION_DECL
4953         && (Ekind (gnat_entity) == E_Function
4954           || Ekind (gnat_entity) == E_Procedure))
4955     || (gnu_old
4956         && (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
4957         && Ekind (gnat_entity) == E_Subprogram_Type)))
4958     return;
4959
4960   /* If we have a non-dummy type old tree, we have nothing to do.   Unless
4961      this is the public view of a private type whose full view was not
4962      delayed, this node was never delayed as it should have been.
4963      Also allow this to happen for concurrent types since we may have
4964      frozen both the Corresponding_Record_Type and this type.  */
4965   if (gnu_old
4966       && !(TREE_CODE (gnu_old) == TYPE_DECL
4967            && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
4968     {
4969       gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4970                    && Present (Full_View (gnat_entity))
4971                    && No (Freeze_Node (Full_View (gnat_entity))))
4972                   || Is_Concurrent_Type (gnat_entity));
4973       return;
4974     }
4975
4976   /* Reset the saved tree, if any, and elaborate the object or type for real.
4977      If there is a full declaration, elaborate it and copy the type to
4978      GNAT_ENTITY.  Likewise if this is the record subtype corresponding to
4979      a class wide type or subtype.  */
4980   if (gnu_old)
4981     {
4982       save_gnu_tree (gnat_entity, NULL_TREE, false);
4983       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4984           && Present (Full_View (gnat_entity))
4985           && present_gnu_tree (Full_View (gnat_entity)))
4986         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
4987       if (Present (Class_Wide_Type (gnat_entity))
4988           && Class_Wide_Type (gnat_entity) != gnat_entity)
4989         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
4990     }
4991
4992   if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4993       && Present (Full_View (gnat_entity)))
4994     {
4995       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
4996
4997       /* Propagate back-annotations from full view to partial view.  */
4998       if (Unknown_Alignment (gnat_entity))
4999         Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
5000
5001       if (Unknown_Esize (gnat_entity))
5002         Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
5003
5004       if (Unknown_RM_Size (gnat_entity))
5005         Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
5006
5007       /* The above call may have defined this entity (the simplest example
5008          of this is when we have a private enumeral type since the bounds
5009          will have the public view.  */
5010       if (!present_gnu_tree (gnat_entity))
5011         save_gnu_tree (gnat_entity, gnu_new, false);
5012       if (Present (Class_Wide_Type (gnat_entity))
5013           && Class_Wide_Type (gnat_entity) != gnat_entity)
5014         save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
5015     }
5016   else
5017     gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
5018
5019   /* If we've made any pointers to the old version of this type, we
5020      have to update them.  */
5021   if (gnu_old)
5022     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
5023                        TREE_TYPE (gnu_new));
5024 }
5025 \f
5026 /* Process the list of inlined subprograms of GNAT_NODE, which is an
5027    N_Compilation_Unit.  */
5028
5029 static void
5030 process_inlined_subprograms (Node_Id gnat_node)
5031 {
5032   Entity_Id gnat_entity;
5033   Node_Id gnat_body;
5034
5035   /* If we can inline, generate RTL for all the inlined subprograms.
5036      Define the entity first so we set DECL_EXTERNAL.  */
5037   if (optimize > 0 && !flag_really_no_inline)
5038     for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5039          Present (gnat_entity);
5040          gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5041       {
5042         gnat_body = Parent (Declaration_Node (gnat_entity));
5043
5044         if (Nkind (gnat_body) != N_Subprogram_Body)
5045           {
5046             /* ??? This really should always be Present.  */
5047             if (No (Corresponding_Body (gnat_body)))
5048               continue;
5049
5050             gnat_body
5051               = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5052           }
5053
5054         if (Present (gnat_body))
5055           {
5056             gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5057             add_stmt (gnat_to_gnu (gnat_body));
5058           }
5059       }
5060 }
5061 \f
5062 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
5063    We make two passes, one to elaborate anything other than bodies (but
5064    we declare a function if there was no spec).  The second pass
5065    elaborates the bodies.
5066
5067    GNAT_END_LIST gives the element in the list past the end.  Normally,
5068    this is Empty, but can be First_Real_Statement for a
5069    Handled_Sequence_Of_Statements.
5070
5071    We make a complete pass through both lists if PASS1P is true, then make
5072    the second pass over both lists if PASS2P is true.  The lists usually
5073    correspond to the public and private parts of a package.  */
5074
5075 static void
5076 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
5077                Node_Id gnat_end_list, bool pass1p, bool pass2p)
5078 {
5079   List_Id gnat_decl_array[2];
5080   Node_Id gnat_decl;
5081   int i;
5082
5083   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
5084
5085   if (pass1p)
5086     for (i = 0; i <= 1; i++)
5087       if (Present (gnat_decl_array[i]))
5088         for (gnat_decl = First (gnat_decl_array[i]);
5089              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
5090           {
5091             /* For package specs, we recurse inside the declarations,
5092                thus taking the two pass approach inside the boundary.  */
5093             if (Nkind (gnat_decl) == N_Package_Declaration
5094                 && (Nkind (Specification (gnat_decl)
5095                            == N_Package_Specification)))
5096               process_decls (Visible_Declarations (Specification (gnat_decl)),
5097                              Private_Declarations (Specification (gnat_decl)),
5098                              Empty, true, false);
5099
5100             /* Similarly for any declarations in the actions of a
5101                freeze node.  */
5102             else if (Nkind (gnat_decl) == N_Freeze_Entity)
5103               {
5104                 process_freeze_entity (gnat_decl);
5105                 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
5106               }
5107
5108             /* Package bodies with freeze nodes get their elaboration deferred
5109                until the freeze node, but the code must be placed in the right
5110                place, so record the code position now.  */
5111             else if (Nkind (gnat_decl) == N_Package_Body
5112                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
5113               record_code_position (gnat_decl);
5114
5115             else if (Nkind (gnat_decl) == N_Package_Body_Stub
5116                      && Present (Library_Unit (gnat_decl))
5117                      && Present (Freeze_Node
5118                                  (Corresponding_Spec
5119                                   (Proper_Body (Unit
5120                                                 (Library_Unit (gnat_decl)))))))
5121               record_code_position
5122                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
5123
5124             /* We defer most subprogram bodies to the second pass.  */
5125             else if (Nkind (gnat_decl) == N_Subprogram_Body)
5126               {
5127                 if (Acts_As_Spec (gnat_decl))
5128                   {
5129                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
5130
5131                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
5132                         && Ekind (gnat_subprog_id) != E_Generic_Function)
5133                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
5134                   }
5135               }
5136             /* For bodies and stubs that act as their own specs, the entity
5137                itself must be elaborated in the first pass, because it may
5138                be used in other declarations. */
5139             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
5140               {
5141                   Node_Id gnat_subprog_id =
5142                      Defining_Entity (Specification (gnat_decl));
5143
5144                     if (Ekind (gnat_subprog_id) != E_Subprogram_Body
5145                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
5146                         && Ekind (gnat_subprog_id) != E_Generic_Function)
5147                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
5148                }
5149
5150             /* Concurrent stubs stand for the corresponding subprogram bodies,
5151                which are deferred like other bodies.  */
5152             else if (Nkind (gnat_decl) == N_Task_Body_Stub
5153                      || Nkind (gnat_decl) == N_Protected_Body_Stub)
5154               ;
5155             else
5156               add_stmt (gnat_to_gnu (gnat_decl));
5157           }
5158
5159   /* Here we elaborate everything we deferred above except for package bodies,
5160      which are elaborated at their freeze nodes.  Note that we must also
5161      go inside things (package specs and freeze nodes) the first pass did.  */
5162   if (pass2p)
5163     for (i = 0; i <= 1; i++)
5164       if (Present (gnat_decl_array[i]))
5165         for (gnat_decl = First (gnat_decl_array[i]);
5166              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
5167           {
5168             if (Nkind (gnat_decl) == N_Subprogram_Body
5169                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
5170                 || Nkind (gnat_decl) == N_Task_Body_Stub
5171                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
5172               add_stmt (gnat_to_gnu (gnat_decl));
5173
5174             else if (Nkind (gnat_decl) == N_Package_Declaration
5175                      && (Nkind (Specification (gnat_decl)
5176                                 == N_Package_Specification)))
5177               process_decls (Visible_Declarations (Specification (gnat_decl)),
5178                              Private_Declarations (Specification (gnat_decl)),
5179                              Empty, false, true);
5180
5181             else if (Nkind (gnat_decl) == N_Freeze_Entity)
5182               process_decls (Actions (gnat_decl), Empty, Empty, false, true);
5183           }
5184 }
5185 \f
5186 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
5187    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
5188    which we have to check. */
5189
5190 static tree
5191 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
5192 {
5193   tree gnu_range_type = get_unpadded_type (gnat_range_type);
5194   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
5195   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
5196   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
5197
5198   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
5199      we can't do anything since we might be truncating the bounds.  No
5200      check is needed in this case.  */
5201   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
5202       && (TYPE_PRECISION (gnu_compare_type)
5203           < TYPE_PRECISION (get_base_type (gnu_range_type))))
5204     return gnu_expr;
5205
5206   /* Checked expressions must be evaluated only once. */
5207   gnu_expr = protect_multiple_eval (gnu_expr);
5208
5209   /* There's no good type to use here, so we might as well use
5210      integer_type_node. Note that the form of the check is
5211         (not (expr >= lo)) or (not (expr >= hi))
5212       the reason for this slightly convoluted form is that NaN's
5213       are not considered to be in range in the float case. */
5214   return emit_check
5215     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5216                       invert_truthvalue
5217                       (build_binary_op (GE_EXPR, integer_type_node,
5218                                        convert (gnu_compare_type, gnu_expr),
5219                                        convert (gnu_compare_type, gnu_low))),
5220                       invert_truthvalue
5221                       (build_binary_op (LE_EXPR, integer_type_node,
5222                                         convert (gnu_compare_type, gnu_expr),
5223                                         convert (gnu_compare_type,
5224                                                  gnu_high)))),
5225      gnu_expr, CE_Range_Check_Failed);
5226 }
5227 \f
5228 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
5229    which we are about to index, GNU_EXPR is the index expression to be
5230    checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
5231    against which GNU_EXPR has to be checked. Note that for index
5232    checking we cannot use the emit_range_check function (although very
5233    similar code needs to be generated in both cases) since for index
5234    checking the array type against which we are checking the indeces
5235    may be unconstrained and consequently we need to retrieve the
5236    actual index bounds from the array object itself
5237    (GNU_ARRAY_OBJECT). The place where we need to do that is in
5238    subprograms having unconstrained array formal parameters */
5239
5240 static tree
5241 emit_index_check (tree gnu_array_object,
5242                   tree gnu_expr,
5243                   tree gnu_low,
5244                   tree gnu_high)
5245 {
5246   tree gnu_expr_check;
5247
5248   /* Checked expressions must be evaluated only once. */
5249   gnu_expr = protect_multiple_eval (gnu_expr);
5250
5251   /* Must do this computation in the base type in case the expression's
5252      type is an unsigned subtypes.  */
5253   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
5254
5255   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
5256      the object we are handling. */
5257   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
5258   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
5259
5260   /* There's no good type to use here, so we might as well use
5261      integer_type_node.   */
5262   return emit_check
5263     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5264                       build_binary_op (LT_EXPR, integer_type_node,
5265                                        gnu_expr_check,
5266                                        convert (TREE_TYPE (gnu_expr_check),
5267                                                 gnu_low)),
5268                       build_binary_op (GT_EXPR, integer_type_node,
5269                                        gnu_expr_check,
5270                                        convert (TREE_TYPE (gnu_expr_check),
5271                                                 gnu_high))),
5272      gnu_expr, CE_Index_Check_Failed);
5273 }
5274 \f
5275 /* GNU_COND contains the condition corresponding to an access, discriminant or
5276    range check of value GNU_EXPR.  Build a COND_EXPR that returns GNU_EXPR if
5277    GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
5278    REASON is the code that says why the exception was raised.  */
5279
5280 static tree
5281 emit_check (tree gnu_cond, tree gnu_expr, int reason)
5282 {
5283   tree gnu_call;
5284   tree gnu_result;
5285
5286   gnu_call = build_call_raise (reason, Empty);
5287
5288   /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
5289      in front of the comparison in case it ends up being a SAVE_EXPR.  Put the
5290      whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
5291      out.  */
5292   gnu_result = fold (build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
5293                              build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
5294                                      gnu_call, gnu_expr),
5295                              gnu_expr));
5296
5297   /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
5298      protect it.  Otherwise, show GNU_RESULT has no side effects: we
5299      don't need to evaluate it just for the check.  */
5300   if (TREE_SIDE_EFFECTS (gnu_expr))
5301     gnu_result
5302       = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
5303   else
5304     TREE_SIDE_EFFECTS (gnu_result) = 0;
5305
5306   /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
5307      we will repeatedly do the test.  It would be nice if GCC was able
5308      to optimize this and only do it once.  */
5309   return save_expr (gnu_result);
5310 }
5311 \f
5312 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
5313    overflow checks if OVERFLOW_P is nonzero and range checks if
5314    RANGE_P is nonzero.  GNAT_TYPE is known to be an integral type.
5315    If TRUNCATE_P is nonzero, do a float to integer conversion with
5316    truncation; otherwise round.  */
5317
5318 static tree
5319 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
5320                     bool rangep, bool truncatep)
5321 {
5322   tree gnu_type = get_unpadded_type (gnat_type);
5323   tree gnu_in_type = TREE_TYPE (gnu_expr);
5324   tree gnu_in_basetype = get_base_type (gnu_in_type);
5325   tree gnu_base_type = get_base_type (gnu_type);
5326   tree gnu_result = gnu_expr;
5327
5328   /* If we are not doing any checks, the output is an integral type, and
5329      the input is not a floating type, just do the conversion.  This
5330      shortcut is required to avoid problems with packed array types
5331      and simplifies code in all cases anyway.   */
5332   if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
5333       && !FLOAT_TYPE_P (gnu_in_type))
5334     return convert (gnu_type, gnu_expr);
5335
5336   /* First convert the expression to its base type.  This
5337      will never generate code, but makes the tests below much simpler.
5338      But don't do this if converting from an integer type to an unconstrained
5339      array type since then we need to get the bounds from the original
5340      (unpacked) type.  */
5341   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
5342     gnu_result = convert (gnu_in_basetype, gnu_result);
5343
5344   /* If overflow checks are requested,  we need to be sure the result will
5345      fit in the output base type.  But don't do this if the input
5346      is integer and the output floating-point.  */
5347   if (overflowp
5348       && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
5349     {
5350       /* Ensure GNU_EXPR only gets evaluated once.  */
5351       tree gnu_input = protect_multiple_eval (gnu_result);
5352       tree gnu_cond = integer_zero_node;
5353       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
5354       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
5355       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
5356       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
5357
5358       /* Convert the lower bounds to signed types, so we're sure we're
5359          comparing them properly.  Likewise, convert the upper bounds
5360          to unsigned types.  */
5361       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
5362         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
5363
5364       if (INTEGRAL_TYPE_P (gnu_in_basetype)
5365           && !TYPE_UNSIGNED (gnu_in_basetype))
5366         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
5367
5368       if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
5369         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
5370
5371       if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
5372         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
5373
5374       /* Check each bound separately and only if the result bound
5375          is tighter than the bound on the input type.  Note that all the
5376          types are base types, so the bounds must be constant. Also,
5377          the comparison is done in the base type of the input, which
5378          always has the proper signedness.  First check for input
5379          integer (which means output integer), output float (which means
5380          both float), or mixed, in which case we always compare.
5381          Note that we have to do the comparison which would *fail* in the
5382          case of an error since if it's an FP comparison and one of the
5383          values is a NaN or Inf, the comparison will fail.  */
5384       if (INTEGRAL_TYPE_P (gnu_in_basetype)
5385           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
5386           : (FLOAT_TYPE_P (gnu_base_type)
5387              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
5388                                  TREE_REAL_CST (gnu_out_lb))
5389              : 1))
5390         gnu_cond
5391           = invert_truthvalue
5392             (build_binary_op (GE_EXPR, integer_type_node,
5393                               gnu_input, convert (gnu_in_basetype,
5394                                                   gnu_out_lb)));
5395
5396       if (INTEGRAL_TYPE_P (gnu_in_basetype)
5397           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
5398           : (FLOAT_TYPE_P (gnu_base_type)
5399              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
5400                                  TREE_REAL_CST (gnu_in_lb))
5401              : 1))
5402         gnu_cond
5403           = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
5404                              invert_truthvalue
5405                              (build_binary_op (LE_EXPR, integer_type_node,
5406                                                gnu_input,
5407                                                convert (gnu_in_basetype,
5408                                                         gnu_out_ub))));
5409
5410       if (!integer_zerop (gnu_cond))
5411         gnu_result = emit_check (gnu_cond, gnu_input,
5412                                  CE_Overflow_Check_Failed);
5413     }
5414
5415   /* Now convert to the result base type.  If this is a non-truncating
5416      float-to-integer conversion, round.  */
5417   if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
5418       && !truncatep)
5419     {
5420       REAL_VALUE_TYPE half_minus_pred_half, pred_half;
5421       tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type;
5422       tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
5423       const struct real_format *fmt;
5424
5425       /* The following calculations depend on proper rounding to even
5426          of each arithmetic operation. In order to prevent excess
5427          precision from spoiling this property, use the widest hardware
5428          floating-point type.
5429
5430          FIXME: For maximum efficiency, this should only be done for machines
5431          and types where intermediates may have extra precision.  */
5432
5433       calc_type = longest_float_type_node;
5434       /* FIXME: Should not have padding in the first place */
5435       if (TREE_CODE (calc_type) == RECORD_TYPE
5436               && TYPE_IS_PADDING_P (calc_type))
5437         calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
5438
5439       /* Compute the exact value calc_type'Pred (0.5) at compile time. */
5440       fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
5441       real_2expN (&half_minus_pred_half, -(fmt->p) - 1);
5442       REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
5443                        half_minus_pred_half);
5444       gnu_pred_half = build_real (calc_type, pred_half);
5445
5446       /* If the input is strictly negative, subtract this value
5447          and otherwise add it from the input. For 0.5, the result
5448          is exactly between 1.0 and the machine number preceding 1.0
5449          (for calc_type). Since the last bit of 1.0 is even, this 0.5
5450          will round to 1.0, while all other number with an absolute
5451          value less than 0.5 round to 0.0. For larger numbers exactly
5452          halfway between integers, rounding will always be correct as
5453          the true mathematical result will be closer to the higher
5454          integer compared to the lower one. So, this constant works
5455          for all floating-point numbers.
5456
5457          The reason to use the same constant with subtract/add instead
5458          of a positive and negative constant is to allow the comparison
5459          to be scheduled in parallel with retrieval of the constant and
5460          conversion of the input to the calc_type (if necessary).
5461       */
5462
5463       gnu_zero = convert (gnu_in_basetype, integer_zero_node);
5464       gnu_saved_result = save_expr (gnu_result);
5465       gnu_conv = convert (calc_type, gnu_saved_result);
5466       gnu_comp = build2 (GE_EXPR, integer_type_node,
5467                         gnu_saved_result, gnu_zero);
5468       gnu_add_pred_half
5469         = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
5470       gnu_subtract_pred_half
5471         = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
5472       gnu_result = build3 (COND_EXPR, calc_type, gnu_comp,
5473                            gnu_add_pred_half, gnu_subtract_pred_half);
5474     }
5475
5476   if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
5477       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
5478       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
5479     gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
5480   else
5481     gnu_result = convert (gnu_base_type, gnu_result);
5482
5483   /* Finally, do the range check if requested.  Note that if the
5484      result type is a modular type, the range check is actually
5485      an overflow check.  */
5486
5487   if (rangep
5488       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
5489           && TYPE_MODULAR_P (gnu_base_type) && overflowp))
5490     gnu_result = emit_range_check (gnu_result, gnat_type);
5491
5492   return convert (gnu_type, gnu_result);
5493 }
5494 \f
5495 /* Return 1 if GNU_EXPR can be directly addressed.  This is the case unless
5496    it is an expression involving computation or if it involves a reference
5497    to a bitfield or to a field not sufficiently aligned for its type.  */
5498
5499 static bool
5500 addressable_p (tree gnu_expr)
5501 {
5502   switch (TREE_CODE (gnu_expr))
5503     {
5504     case VAR_DECL:
5505     case PARM_DECL:
5506     case FUNCTION_DECL:
5507     case RESULT_DECL:
5508       /* All DECLs are addressable: if they are in a register, we can force
5509          them to memory.  */
5510       return true;
5511
5512     case UNCONSTRAINED_ARRAY_REF:
5513     case INDIRECT_REF:
5514     case CONSTRUCTOR:
5515     case NULL_EXPR:
5516     case SAVE_EXPR:
5517       return true;
5518
5519     case COMPONENT_REF:
5520       return (!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
5521               && (!STRICT_ALIGNMENT
5522                   /* If the field was marked as "semantically" addressable
5523                      in create_field_decl, we are guaranteed that it can
5524                      be directly addressed.  */
5525                   || !DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr, 1))
5526                   /* Otherwise it can nevertheless be directly addressed
5527                      if it has been sufficiently aligned in the record.  */
5528                   || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
5529                        >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))
5530               && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5531
5532     case ARRAY_REF:  case ARRAY_RANGE_REF:
5533     case REALPART_EXPR:  case IMAGPART_EXPR:
5534     case NOP_EXPR:
5535       return addressable_p (TREE_OPERAND (gnu_expr, 0));
5536
5537     case CONVERT_EXPR:
5538       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
5539               && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5540
5541     case VIEW_CONVERT_EXPR:
5542       {
5543         /* This is addressable if we can avoid a copy.  */
5544         tree type = TREE_TYPE (gnu_expr);
5545         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
5546
5547         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
5548                   && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
5549                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
5550                  || ((TYPE_MODE (type) == BLKmode
5551                       || TYPE_MODE (inner_type) == BLKmode)
5552                      && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
5553                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
5554                          || TYPE_ALIGN_OK (type)
5555                          || TYPE_ALIGN_OK (inner_type))))
5556                 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5557       }
5558
5559     default:
5560       return false;
5561     }
5562 }
5563 \f
5564 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
5565    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
5566    make a GCC type for GNAT_ENTITY and set up the correspondence.  */
5567
5568 void
5569 process_type (Entity_Id gnat_entity)
5570 {
5571   tree gnu_old
5572     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
5573   tree gnu_new;
5574
5575   /* If we are to delay elaboration of this type, just do any
5576      elaborations needed for expressions within the declaration and
5577      make a dummy type entry for this node and its Full_View (if
5578      any) in case something points to it.  Don't do this if it
5579      has already been done (the only way that can happen is if
5580      the private completion is also delayed).  */
5581   if (Present (Freeze_Node (gnat_entity))
5582       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5583           && Present (Full_View (gnat_entity))
5584           && Freeze_Node (Full_View (gnat_entity))
5585           && !present_gnu_tree (Full_View (gnat_entity))))
5586     {
5587       elaborate_entity (gnat_entity);
5588
5589       if (!gnu_old)
5590         {
5591           tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
5592                                             make_dummy_type (gnat_entity),
5593                                             NULL, false, false, gnat_entity);
5594
5595           save_gnu_tree (gnat_entity, gnu_decl, false);
5596           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5597               && Present (Full_View (gnat_entity)))
5598             save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
5599         }
5600
5601       return;
5602     }
5603
5604   /* If we saved away a dummy type for this node it means that this
5605      made the type that corresponds to the full type of an incomplete
5606      type.  Clear that type for now and then update the type in the
5607      pointers.  */
5608   if (gnu_old)
5609     {
5610       if (TREE_CODE (gnu_old) != TYPE_DECL
5611           || !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
5612         {
5613           /* If this was a withed access type, this is not an error
5614              and merely indicates we've already elaborated the type
5615              already. */
5616           gcc_assert (Is_Type (gnat_entity) && From_With_Type (gnat_entity));
5617           return;
5618         }
5619
5620       save_gnu_tree (gnat_entity, NULL_TREE, false);
5621     }
5622
5623   /* Now fully elaborate the type.  */
5624   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
5625   gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
5626
5627   /* If we have an old type and we've made pointers to this type,
5628      update those pointers.  */
5629   if (gnu_old)
5630     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
5631                        TREE_TYPE (gnu_new));
5632
5633   /* If this is a record type corresponding to a task or protected type
5634      that is a completion of an incomplete type, perform a similar update
5635      on the type.  */
5636   /* ??? Including protected types here is a guess. */
5637
5638   if (IN (Ekind (gnat_entity), Record_Kind)
5639       && Is_Concurrent_Record_Type (gnat_entity)
5640       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
5641     {
5642       tree gnu_task_old
5643         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
5644
5645       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
5646                      NULL_TREE, false);
5647       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
5648                      gnu_new, false);
5649
5650       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
5651                          TREE_TYPE (gnu_new));
5652     }
5653 }
5654 \f
5655 /* GNAT_ENTITY is the type of the resulting constructors,
5656    GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
5657    and GNU_TYPE is the GCC type of the corresponding record.
5658
5659    Return a CONSTRUCTOR to build the record.  */
5660
5661 static tree
5662 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
5663 {
5664   tree gnu_list, gnu_result;
5665
5666   /* We test for GNU_FIELD being empty in the case where a variant
5667      was the last thing since we don't take things off GNAT_ASSOC in
5668      that case.  We check GNAT_ASSOC in case we have a variant, but it
5669      has no fields.  */
5670
5671   for (gnu_list = NULL_TREE; Present (gnat_assoc);
5672        gnat_assoc = Next (gnat_assoc))
5673     {
5674       Node_Id gnat_field = First (Choices (gnat_assoc));
5675       tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
5676       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
5677
5678       /* The expander is supposed to put a single component selector name
5679          in every record component association */
5680       gcc_assert (No (Next (gnat_field)));
5681
5682       /* Ignore fields that have Corresponding_Discriminants since we'll
5683          be setting that field in the parent.  */
5684       if (Present (Corresponding_Discriminant (Entity (gnat_field)))
5685           && Is_Tagged_Type (Scope (Entity (gnat_field))))
5686         continue;
5687
5688       /* Also ignore discriminants of Unchecked_Unions.  */
5689       else if (Is_Unchecked_Union (gnat_entity)
5690                && Ekind (Entity (gnat_field)) == E_Discriminant)
5691         continue;
5692
5693       /* Before assigning a value in an aggregate make sure range checks
5694          are done if required.  Then convert to the type of the field.  */
5695       if (Do_Range_Check (Expression (gnat_assoc)))
5696         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
5697
5698       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
5699
5700       /* Add the field and expression to the list.  */
5701       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
5702     }
5703
5704   gnu_result = extract_values (gnu_list, gnu_type);
5705
5706 #ifdef ENABLE_CHECKING
5707   {
5708     tree gnu_field;
5709
5710     /* Verify every enty in GNU_LIST was used.  */
5711     for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
5712       gcc_assert (TREE_ADDRESSABLE (gnu_field));
5713   }
5714 #endif
5715
5716   return gnu_result;
5717 }
5718
5719 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
5720    is the first element of an array aggregate. It may itself be an
5721    aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
5722    corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
5723    of the array component. It is needed for range checking. */
5724
5725 static tree
5726 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
5727                     Entity_Id gnat_component_type)
5728 {
5729   tree gnu_expr_list = NULL_TREE;
5730   tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
5731   tree gnu_expr;
5732
5733   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
5734     {
5735       /* If the expression is itself an array aggregate then first build the
5736          innermost constructor if it is part of our array (multi-dimensional
5737          case).  */
5738
5739       if (Nkind (gnat_expr) == N_Aggregate
5740           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
5741           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
5742         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
5743                                        TREE_TYPE (gnu_array_type),
5744                                        gnat_component_type);
5745       else
5746         {
5747           gnu_expr = gnat_to_gnu (gnat_expr);
5748
5749           /* before assigning the element to the array make sure it is
5750              in range */
5751           if (Do_Range_Check (gnat_expr))
5752             gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
5753         }
5754
5755       gnu_expr_list
5756         = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr),
5757                      gnu_expr_list);
5758
5759       gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
5760     }
5761
5762   return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
5763 }
5764 \f
5765 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5766    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
5767    of the associations that are from RECORD_TYPE.  If we see an internal
5768    record, make a recursive call to fill it in as well.  */
5769
5770 static tree
5771 extract_values (tree values, tree record_type)
5772 {
5773   tree result = NULL_TREE;
5774   tree field, tem;
5775
5776   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
5777     {
5778       tree value = 0;
5779
5780       /* _Parent is an internal field, but may have values in the aggregate,
5781          so check for values first.  */
5782       if ((tem = purpose_member (field, values)))
5783         {
5784           value = TREE_VALUE (tem);
5785           TREE_ADDRESSABLE (tem) = 1;
5786         }
5787
5788       else if (DECL_INTERNAL_P (field))
5789         {
5790           value = extract_values (values, TREE_TYPE (field));
5791           if (TREE_CODE (value) == CONSTRUCTOR
5792               && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
5793             value = 0;
5794         }
5795       else
5796         /* If we have a record subtype, the names will match, but not the
5797            actual FIELD_DECLs.  */
5798         for (tem = values; tem; tem = TREE_CHAIN (tem))
5799           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
5800             {
5801               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
5802               TREE_ADDRESSABLE (tem) = 1;
5803             }
5804
5805       if (!value)
5806         continue;
5807
5808       result = tree_cons (field, value, result);
5809     }
5810
5811   return gnat_build_constructor (record_type, nreverse (result));
5812 }
5813 \f
5814 /* EXP is to be treated as an array or record.  Handle the cases when it is
5815    an access object and perform the required dereferences.  */
5816
5817 static tree
5818 maybe_implicit_deref (tree exp)
5819 {
5820   /* If the type is a pointer, dereference it.  */
5821
5822   if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
5823     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
5824
5825   /* If we got a padded type, remove it too.  */
5826   if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
5827       && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
5828     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
5829
5830   return exp;
5831 }
5832 \f
5833 /* Protect EXP from multiple evaluation.  This may make a SAVE_EXPR.  */
5834
5835 tree
5836 protect_multiple_eval (tree exp)
5837 {
5838   tree type = TREE_TYPE (exp);
5839
5840   /* If this has no side effects, we don't need to do anything.  */
5841   if (!TREE_SIDE_EFFECTS (exp))
5842     return exp;
5843
5844   /* If it is a conversion, protect what's inside the conversion.
5845      Similarly, if we're indirectly referencing something, we only
5846      actually need to protect the address since the data itself can't
5847      change in these situations.  */
5848   else if (TREE_CODE (exp) == NON_LVALUE_EXPR
5849            || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR
5850            || TREE_CODE (exp) == VIEW_CONVERT_EXPR
5851            || TREE_CODE (exp) == INDIRECT_REF
5852            || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
5853     return build1 (TREE_CODE (exp), type,
5854                    protect_multiple_eval (TREE_OPERAND (exp, 0)));
5855
5856   /* If EXP is a fat pointer or something that can be placed into a register,
5857      just make a SAVE_EXPR.  */
5858   if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
5859     return save_expr (exp);
5860
5861   /* Otherwise, dereference, protect the address, and re-reference.  */
5862   else
5863     return
5864       build_unary_op (INDIRECT_REF, type,
5865                       save_expr (build_unary_op (ADDR_EXPR,
5866                                                  build_reference_type (type),
5867                                                  exp)));
5868 }
5869 \f
5870 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know how
5871    to handle our new nodes and we take extra arguments:
5872
5873    FORCE says whether to force evaluation of everything,
5874
5875    SUCCESS we set to true unless we walk through something we don't know how
5876    to stabilize, or through something which is not an lvalue and LVALUES_ONLY
5877    is true, in which cases we set to false.  */
5878
5879 tree
5880 maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
5881                            bool *success)
5882 {
5883   tree type = TREE_TYPE (ref);
5884   enum tree_code code = TREE_CODE (ref);
5885   tree result;
5886
5887   /* Assume we'll success unless proven otherwise.  */
5888   *success = true;
5889
5890   switch (code)
5891     {
5892     case VAR_DECL:
5893     case PARM_DECL:
5894     case RESULT_DECL:
5895       /* No action is needed in this case.  */
5896       return ref;
5897
5898     case ADDR_EXPR:
5899       /*  A standalone ADDR_EXPR is never an lvalue, and this one can't
5900           be nested inside an outer INDIRECT_REF, since INDIREC_REF goes
5901           straight to stabilize_1.  */
5902       if (lvalues_only)
5903         goto failure;
5904
5905       /* ... Fallthru ... */
5906
5907     case NOP_EXPR:
5908     case CONVERT_EXPR:
5909     case FLOAT_EXPR:
5910     case FIX_TRUNC_EXPR:
5911     case FIX_FLOOR_EXPR:
5912     case FIX_ROUND_EXPR:
5913     case FIX_CEIL_EXPR:
5914     case VIEW_CONVERT_EXPR:
5915       result
5916         = build1 (code, type,
5917                   maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
5918                                              lvalues_only, success));
5919       break;
5920
5921     case INDIRECT_REF:
5922     case UNCONSTRAINED_ARRAY_REF:
5923       result = build1 (code, type,
5924                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5925                                                    force));
5926       break;
5927
5928     case COMPONENT_REF:
5929      result = build3 (COMPONENT_REF, type,
5930                       maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
5931                                                  lvalues_only, success),
5932                       TREE_OPERAND (ref, 1), NULL_TREE);
5933       break;
5934
5935     case BIT_FIELD_REF:
5936       result = build3 (BIT_FIELD_REF, type,
5937                        maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
5938                                                   lvalues_only, success),
5939                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5940                                                    force),
5941                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
5942                                                    force));
5943       break;
5944
5945     case ARRAY_REF:
5946     case ARRAY_RANGE_REF:
5947       result = build4 (code, type,
5948                        maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
5949                                                   lvalues_only, success),
5950                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5951                                                    force),
5952                        NULL_TREE, NULL_TREE);
5953       break;
5954
5955     case COMPOUND_EXPR:
5956       result = build2 (COMPOUND_EXPR, type,
5957                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5958                                                    force),
5959                        maybe_stabilize_reference (TREE_OPERAND (ref, 1), force,
5960                                                   lvalues_only, success));
5961       break;
5962
5963     case ERROR_MARK:
5964       ref = error_mark_node;
5965
5966       /* ...  Fallthru to failure ... */
5967
5968       /* If arg isn't a kind of lvalue we recognize, make no change.
5969          Caller should recognize the error for an invalid lvalue.  */
5970     default:
5971     failure:
5972       *success = false;
5973       return ref;
5974     }
5975
5976   TREE_READONLY (result) = TREE_READONLY (ref);
5977
5978   /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
5979      expression may not be sustained across some paths, such as the way via
5980      build1 for INDIRECT_REF.  We re-populate those flags here for the general
5981      case, which is consistent with the GCC version of this routine.
5982
5983      Special care should be taken regarding TREE_SIDE_EFFECTS, because some
5984      paths introduce side effects where there was none initially (e.g. calls
5985      to save_expr), and we also want to keep track of that.  */
5986
5987   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
5988   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
5989
5990   return result;
5991 }
5992
5993 /* Wrapper around maybe_stabilize_reference, for common uses without
5994    lvalue restrictions and without need to examine the success
5995    indication.  */
5996
5997 tree
5998 gnat_stabilize_reference (tree ref, bool force)
5999 {
6000   bool stabilized;
6001   return maybe_stabilize_reference (ref, force, false, &stabilized);
6002 }
6003
6004 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
6005    arg to force a SAVE_EXPR for everything.  */
6006
6007 static tree
6008 gnat_stabilize_reference_1 (tree e, bool force)
6009 {
6010   enum tree_code code = TREE_CODE (e);
6011   tree type = TREE_TYPE (e);
6012   tree result;
6013
6014   /* We cannot ignore const expressions because it might be a reference
6015      to a const array but whose index contains side-effects.  But we can
6016      ignore things that are actual constant or that already have been
6017      handled by this function.  */
6018
6019   if (TREE_CONSTANT (e) || code == SAVE_EXPR)
6020     return e;
6021
6022   switch (TREE_CODE_CLASS (code))
6023     {
6024     case tcc_exceptional:
6025     case tcc_type:
6026     case tcc_declaration:
6027     case tcc_comparison:
6028     case tcc_statement:
6029     case tcc_expression:
6030     case tcc_reference:
6031       /* If this is a COMPONENT_REF of a fat pointer, save the entire
6032          fat pointer.  This may be more efficient, but will also allow
6033          us to more easily find the match for the PLACEHOLDER_EXPR.  */
6034       if (code == COMPONENT_REF
6035           && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
6036         result = build3 (COMPONENT_REF, type,
6037                          gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
6038                                                      force),
6039                          TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
6040       else if (TREE_SIDE_EFFECTS (e) || force)
6041         return save_expr (e);
6042       else
6043         return e;
6044       break;
6045
6046     case tcc_constant:
6047       /* Constants need no processing.  In fact, we should never reach
6048          here.  */
6049       return e;
6050
6051     case tcc_binary:
6052       /* Recursively stabilize each operand.  */
6053       result = build2 (code, type,
6054                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
6055                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
6056                                                    force));
6057       break;
6058
6059     case tcc_unary:
6060       /* Recursively stabilize each operand.  */
6061       result = build1 (code, type,
6062                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
6063                                                    force));
6064       break;
6065
6066     default:
6067       gcc_unreachable ();
6068     }
6069
6070   TREE_READONLY (result) = TREE_READONLY (e);
6071
6072   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
6073   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
6074   return result;
6075 }
6076
6077 /* Build a global constructor or destructor function.  METHOD_TYPE gives
6078    the type of the function and CDTORS points to the list of constructor
6079    or destructor functions to be invoked.  FIXME: Migrate into cgraph.  */
6080
6081 static void
6082 build_global_cdtor (int method_type, tree *cdtors)
6083 {
6084   tree body = 0;
6085
6086   for (; *cdtors; *cdtors = TREE_CHAIN (*cdtors))
6087     {
6088       tree fn = TREE_VALUE (*cdtors);
6089       tree fntype = TREE_TYPE (fn);
6090       tree fnaddr = build1 (ADDR_EXPR, build_pointer_type (fntype), fn);
6091       tree fncall = build3 (CALL_EXPR, TREE_TYPE (fntype), fnaddr, NULL_TREE,
6092                             NULL_TREE);
6093       append_to_statement_list (fncall, &body);
6094     }
6095
6096   cgraph_build_static_cdtor (method_type, body, DEFAULT_INIT_PRIORITY);
6097 }
6098 \f
6099 extern char *__gnat_to_canonical_file_spec (char *);
6100
6101 /* Convert Sloc into *LOCUS (a location_t).  Return true if this Sloc
6102    corresponds to a source code location and false if it doesn't.  In the
6103    latter case, we don't update *LOCUS.  We also set the Gigi global variable
6104    REF_FILENAME to the reference file name as given by sinput (i.e no
6105    directory).  */
6106
6107 bool
6108 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
6109 {
6110   /* If node not from source code, ignore.  */
6111   if (Sloc < 0)
6112     return false;
6113
6114   /* Use the identifier table to make a hashed, permanent copy of the filename,
6115      since the name table gets reallocated after Gigi returns but before all
6116      the debugging information is output. The __gnat_to_canonical_file_spec
6117      call translates filenames from pragmas Source_Reference that contain host
6118      style syntax not understood by gdb. */
6119   locus->file
6120     = IDENTIFIER_POINTER
6121       (get_identifier
6122        (__gnat_to_canonical_file_spec
6123         (Get_Name_String (Full_Debug_Name (Get_Source_File_Index (Sloc))))));
6124
6125   locus->line = Get_Logical_Line_Number (Sloc);
6126
6127   ref_filename
6128     = IDENTIFIER_POINTER
6129       (get_identifier
6130        (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
6131
6132   return true;
6133 }
6134
6135 /* Similar to annotate_with_locus, but start with the Sloc of GNAT_NODE and
6136    don't do anything if it doesn't correspond to a source location.  */
6137
6138 static void
6139 annotate_with_node (tree node, Node_Id gnat_node)
6140 {
6141   location_t locus;
6142
6143   if (!Sloc_to_locus (Sloc (gnat_node), &locus))
6144     return;
6145
6146   annotate_with_locus (node, locus);
6147 }
6148 \f
6149 /* Post an error message.  MSG is the error message, properly annotated.
6150    NODE is the node at which to post the error and the node to use for the
6151    "&" substitution.  */
6152
6153 void
6154 post_error (const char *msg, Node_Id node)
6155 {
6156   String_Template temp;
6157   Fat_Pointer fp;
6158
6159   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6160   fp.Array = msg, fp.Bounds = &temp;
6161   if (Present (node))
6162     Error_Msg_N (fp, node);
6163 }
6164
6165 /* Similar, but NODE is the node at which to post the error and ENT
6166    is the node to use for the "&" substitution.  */
6167
6168 void
6169 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
6170 {
6171   String_Template temp;
6172   Fat_Pointer fp;
6173
6174   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6175   fp.Array = msg, fp.Bounds = &temp;
6176   if (Present (node))
6177     Error_Msg_NE (fp, node, ent);
6178 }
6179
6180 /* Similar, but NODE is the node at which to post the error, ENT is the node
6181    to use for the "&" substitution, and N is the number to use for the ^.  */
6182
6183 void
6184 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
6185 {
6186   String_Template temp;
6187   Fat_Pointer fp;
6188
6189   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6190   fp.Array = msg, fp.Bounds = &temp;
6191   Error_Msg_Uint_1 = UI_From_Int (n);
6192
6193   if (Present (node))
6194     Error_Msg_NE (fp, node, ent);
6195 }
6196 \f
6197 /* Similar to post_error_ne_num, but T is a GCC tree representing the
6198    number to write.  If the tree represents a constant that fits within
6199    a host integer, the text inside curly brackets in MSG will be output
6200    (presumably including a '^').  Otherwise that text will not be output
6201    and the text inside square brackets will be output instead.  */
6202
6203 void
6204 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
6205 {
6206   char *newmsg = alloca (strlen (msg) + 1);
6207   String_Template temp = {1, 0};
6208   Fat_Pointer fp;
6209   char start_yes, end_yes, start_no, end_no;
6210   const char *p;
6211   char *q;
6212
6213   fp.Array = newmsg, fp.Bounds = &temp;
6214
6215   if (host_integerp (t, 1)
6216 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
6217       &&
6218       compare_tree_int
6219       (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
6220 #endif
6221       )
6222     {
6223       Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
6224       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
6225     }
6226   else
6227     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
6228
6229   for (p = msg, q = newmsg; *p; p++)
6230     {
6231       if (*p == start_yes)
6232         for (p++; *p != end_yes; p++)
6233           *q++ = *p;
6234       else if (*p == start_no)
6235         for (p++; *p != end_no; p++)
6236           ;
6237       else
6238         *q++ = *p;
6239     }
6240
6241   *q = 0;
6242
6243   temp.High_Bound = strlen (newmsg);
6244   if (Present (node))
6245     Error_Msg_NE (fp, node, ent);
6246 }
6247
6248 /* Similar to post_error_ne_tree, except that NUM is a second
6249    integer to write in the message.  */
6250
6251 void
6252 post_error_ne_tree_2 (const char *msg,
6253                       Node_Id node,
6254                       Entity_Id ent,
6255                       tree t,
6256                       int num)
6257 {
6258   Error_Msg_Uint_2 = UI_From_Int (num);
6259   post_error_ne_tree (msg, node, ent, t);
6260 }
6261 \f
6262 /* Initialize the table that maps GNAT codes to GCC codes for simple
6263    binary and unary operations.  */
6264
6265 void
6266 init_code_table (void)
6267 {
6268   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
6269   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
6270
6271   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
6272   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
6273   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
6274   gnu_codes[N_Op_Eq] = EQ_EXPR;
6275   gnu_codes[N_Op_Ne] = NE_EXPR;
6276   gnu_codes[N_Op_Lt] = LT_EXPR;
6277   gnu_codes[N_Op_Le] = LE_EXPR;
6278   gnu_codes[N_Op_Gt] = GT_EXPR;
6279   gnu_codes[N_Op_Ge] = GE_EXPR;
6280   gnu_codes[N_Op_Add] = PLUS_EXPR;
6281   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
6282   gnu_codes[N_Op_Multiply] = MULT_EXPR;
6283   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
6284   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
6285   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
6286   gnu_codes[N_Op_Abs] = ABS_EXPR;
6287   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
6288   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
6289   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
6290   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
6291   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
6292   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
6293 }
6294
6295 #include "gt-ada-trans.h"