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