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-2007, 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 translated 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 = build_call_list (TREE_TYPE (gnu_subprog_type),
1996                                       gnu_subprog_addr,
1997                                       nreverse (gnu_actual_list));
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_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           = build_int_cst_type
2733               (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
2734       break;
2735
2736     case N_Real_Literal:
2737       /* If this is of a fixed-point type, the value we want is the
2738          value of the corresponding integer.  */
2739       if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
2740         {
2741           gnu_result_type = get_unpadded_type (Etype (gnat_node));
2742           gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
2743                                   gnu_result_type);
2744           gcc_assert (!TREE_OVERFLOW (gnu_result));
2745         }
2746
2747       /* We should never see a Vax_Float type literal, since the front end
2748          is supposed to transform these using appropriate conversions */
2749       else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
2750         gcc_unreachable ();
2751
2752       else
2753         {
2754           Ureal ur_realval = Realval (gnat_node);
2755
2756           gnu_result_type = get_unpadded_type (Etype (gnat_node));
2757
2758           /* If the real value is zero, so is the result.  Otherwise,
2759              convert it to a machine number if it isn't already.  That
2760              forces BASE to 0 or 2 and simplifies the rest of our logic.  */
2761           if (UR_Is_Zero (ur_realval))
2762             gnu_result = convert (gnu_result_type, integer_zero_node);
2763           else
2764             {
2765               if (!Is_Machine_Number (gnat_node))
2766                 ur_realval
2767                   = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
2768                              ur_realval, Round_Even, gnat_node);
2769
2770               gnu_result
2771                 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
2772
2773               /* If we have a base of zero, divide by the denominator.
2774                  Otherwise, the base must be 2 and we scale the value, which
2775                  we know can fit in the mantissa of the type (hence the use
2776                  of that type above).  */
2777               if (No (Rbase (ur_realval)))
2778                 gnu_result
2779                   = build_binary_op (RDIV_EXPR,
2780                                      get_base_type (gnu_result_type),
2781                                      gnu_result,
2782                                      UI_To_gnu (Denominator (ur_realval),
2783                                                 gnu_result_type));
2784               else
2785                 {
2786                   REAL_VALUE_TYPE tmp;
2787
2788                   gcc_assert (Rbase (ur_realval) == 2);
2789                   real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
2790                               - UI_To_Int (Denominator (ur_realval)));
2791                   gnu_result = build_real (gnu_result_type, tmp);
2792                 }
2793             }
2794
2795           /* Now see if we need to negate the result.  Do it this way to
2796              properly handle -0.  */
2797           if (UR_Is_Negative (Realval (gnat_node)))
2798             gnu_result
2799               = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
2800                                 gnu_result);
2801         }
2802
2803       break;
2804
2805     case N_String_Literal:
2806       gnu_result_type = get_unpadded_type (Etype (gnat_node));
2807       if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
2808         {
2809           String_Id gnat_string = Strval (gnat_node);
2810           int length = String_Length (gnat_string);
2811           char *string = (char *) alloca (length + 1);
2812           int i;
2813
2814           /* Build the string with the characters in the literal.  Note
2815              that Ada strings are 1-origin.  */
2816           for (i = 0; i < length; i++)
2817             string[i] = Get_String_Char (gnat_string, i + 1);
2818
2819           /* Put a null at the end of the string in case it's in a context
2820              where GCC will want to treat it as a C string.  */
2821           string[i] = 0;
2822
2823           gnu_result = build_string (length, string);
2824
2825           /* Strings in GCC don't normally have types, but we want
2826              this to not be converted to the array type.  */
2827           TREE_TYPE (gnu_result) = gnu_result_type;
2828         }
2829       else
2830         {
2831           /* Build a list consisting of each character, then make
2832              the aggregate.  */
2833           String_Id gnat_string = Strval (gnat_node);
2834           int length = String_Length (gnat_string);
2835           int i;
2836           tree gnu_list = NULL_TREE;
2837           tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
2838
2839           for (i = 0; i < length; i++)
2840             {
2841               gnu_list
2842                 = tree_cons (gnu_idx,
2843                              build_int_cst (TREE_TYPE (gnu_result_type),
2844                                             Get_String_Char (gnat_string,
2845                                                              i + 1)),
2846                              gnu_list);
2847
2848               gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
2849                                          0);
2850             }
2851
2852           gnu_result
2853             = gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
2854         }
2855       break;
2856
2857     case N_Pragma:
2858       gnu_result = Pragma_to_gnu (gnat_node);
2859       break;
2860
2861     /**************************************/
2862     /* Chapter 3: Declarations and Types: */
2863     /**************************************/
2864
2865     case N_Subtype_Declaration:
2866     case N_Full_Type_Declaration:
2867     case N_Incomplete_Type_Declaration:
2868     case N_Private_Type_Declaration:
2869     case N_Private_Extension_Declaration:
2870     case N_Task_Type_Declaration:
2871       process_type (Defining_Entity (gnat_node));
2872       gnu_result = alloc_stmt_list ();
2873       break;
2874
2875     case N_Object_Declaration:
2876     case N_Exception_Declaration:
2877       gnat_temp = Defining_Entity (gnat_node);
2878       gnu_result = alloc_stmt_list ();
2879
2880       /* If we are just annotating types and this object has an unconstrained
2881          or task type, don't elaborate it.   */
2882       if (type_annotate_only
2883           && (((Is_Array_Type (Etype (gnat_temp))
2884                 || Is_Record_Type (Etype (gnat_temp)))
2885                && !Is_Constrained (Etype (gnat_temp)))
2886             || Is_Concurrent_Type (Etype (gnat_temp))))
2887         break;
2888
2889       if (Present (Expression (gnat_node))
2890           && !(Nkind (gnat_node) == N_Object_Declaration
2891                && No_Initialization (gnat_node))
2892           && (!type_annotate_only
2893               || Compile_Time_Known_Value (Expression (gnat_node))))
2894         {
2895           gnu_expr = gnat_to_gnu (Expression (gnat_node));
2896           if (Do_Range_Check (Expression (gnat_node)))
2897             gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
2898
2899           /* If this object has its elaboration delayed, we must force
2900              evaluation of GNU_EXPR right now and save it for when the object
2901              is frozen.  */
2902           if (Present (Freeze_Node (gnat_temp)))
2903             {
2904               if ((Is_Public (gnat_temp) || global_bindings_p ())
2905                   && !TREE_CONSTANT (gnu_expr))
2906                 gnu_expr
2907                   = create_var_decl (create_concat_name (gnat_temp, "init"),
2908                                      NULL_TREE, TREE_TYPE (gnu_expr),
2909                                      gnu_expr, false, Is_Public (gnat_temp),
2910                                      false, false, NULL, gnat_temp);
2911               else
2912                 gnu_expr = maybe_variable (gnu_expr);
2913
2914               save_gnu_tree (gnat_node, gnu_expr, true);
2915             }
2916         }
2917       else
2918         gnu_expr = NULL_TREE;
2919
2920       if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
2921         gnu_expr = NULL_TREE;
2922
2923       if (No (Freeze_Node (gnat_temp)))
2924         gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
2925       break;
2926
2927     case N_Object_Renaming_Declaration:
2928       gnat_temp = Defining_Entity (gnat_node);
2929
2930       /* Don't do anything if this renaming is handled by the front end or if
2931          we are just annotating types and this object has a composite or task
2932          type, don't elaborate it.  We return the result in case it has any
2933          SAVE_EXPRs in it that need to be evaluated here.  */
2934       if (!Is_Renaming_Of_Object (gnat_temp)
2935           && ! (type_annotate_only
2936                 && (Is_Array_Type (Etype (gnat_temp))
2937                     || Is_Record_Type (Etype (gnat_temp))
2938                     || Is_Concurrent_Type (Etype (gnat_temp)))))
2939         gnu_result
2940           = gnat_to_gnu_entity (gnat_temp,
2941                                 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
2942       else
2943         gnu_result = alloc_stmt_list ();
2944       break;
2945
2946     case N_Implicit_Label_Declaration:
2947       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
2948       gnu_result = alloc_stmt_list ();
2949       break;
2950
2951     case N_Exception_Renaming_Declaration:
2952     case N_Number_Declaration:
2953     case N_Package_Renaming_Declaration:
2954     case N_Subprogram_Renaming_Declaration:
2955       /* These are fully handled in the front end.  */
2956       gnu_result = alloc_stmt_list ();
2957       break;
2958
2959     /*************************************/
2960     /* Chapter 4: Names and Expressions: */
2961     /*************************************/
2962
2963     case N_Explicit_Dereference:
2964       gnu_result = gnat_to_gnu (Prefix (gnat_node));
2965       gnu_result_type = get_unpadded_type (Etype (gnat_node));
2966       gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2967       break;
2968
2969     case N_Indexed_Component:
2970       {
2971         tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
2972         tree gnu_type;
2973         int ndim;
2974         int i;
2975         Node_Id *gnat_expr_array;
2976
2977         gnu_array_object = maybe_implicit_deref (gnu_array_object);
2978         gnu_array_object = maybe_unconstrained_array (gnu_array_object);
2979
2980         /* If we got a padded type, remove it too.  */
2981         if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
2982             && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
2983           gnu_array_object
2984             = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
2985                        gnu_array_object);
2986
2987         gnu_result = gnu_array_object;
2988
2989         /* First compute the number of dimensions of the array, then
2990            fill the expression array, the order depending on whether
2991            this is a Convention_Fortran array or not.  */
2992         for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
2993              TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2994              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
2995              ndim++, gnu_type = TREE_TYPE (gnu_type))
2996           ;
2997
2998         gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
2999
3000         if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
3001           for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
3002                i >= 0;
3003                i--, gnat_temp = Next (gnat_temp))
3004             gnat_expr_array[i] = gnat_temp;
3005         else
3006           for (i = 0, gnat_temp = First (Expressions (gnat_node));
3007                i < ndim;
3008                i++, gnat_temp = Next (gnat_temp))
3009             gnat_expr_array[i] = gnat_temp;
3010
3011         for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
3012              i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
3013           {
3014             gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
3015             gnat_temp = gnat_expr_array[i];
3016             gnu_expr = gnat_to_gnu (gnat_temp);
3017
3018             if (Do_Range_Check (gnat_temp))
3019               gnu_expr
3020                 = emit_index_check
3021                   (gnu_array_object, gnu_expr,
3022                    TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
3023                    TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
3024
3025             gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
3026                                           gnu_result, gnu_expr);
3027           }
3028       }
3029
3030       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3031       break;
3032
3033     case N_Slice:
3034       {
3035         tree gnu_type;
3036         Node_Id gnat_range_node = Discrete_Range (gnat_node);
3037
3038         gnu_result = gnat_to_gnu (Prefix (gnat_node));
3039         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3040
3041         /* Do any implicit dereferences of the prefix and do any needed
3042            range check.  */
3043         gnu_result = maybe_implicit_deref (gnu_result);
3044         gnu_result = maybe_unconstrained_array (gnu_result);
3045         gnu_type = TREE_TYPE (gnu_result);
3046         if (Do_Range_Check (gnat_range_node))
3047           {
3048             /* Get the bounds of the slice. */
3049             tree gnu_index_type
3050               = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
3051             tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
3052             tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
3053             tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
3054
3055             /* Check to see that the minimum slice value is in range */
3056             gnu_expr_l
3057               = emit_index_check
3058                 (gnu_result, gnu_min_expr,
3059                  TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
3060                  TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
3061
3062             /* Check to see that the maximum slice value is in range */
3063             gnu_expr_h
3064               = emit_index_check
3065                 (gnu_result, gnu_max_expr,
3066                  TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
3067                  TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
3068
3069             /* Derive a good type to convert everything too */
3070             gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
3071
3072             /* Build a compound expression that does the range checks */
3073             gnu_expr
3074               = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
3075                                  convert (gnu_expr_type, gnu_expr_h),
3076                                  convert (gnu_expr_type, gnu_expr_l));
3077
3078             /* Build a conditional expression that returns the range checks
3079                expression if the slice range is not null (max >= min) or
3080                returns the min if the slice range is null */
3081             gnu_expr
3082               = fold (build3 (COND_EXPR, gnu_expr_type,
3083                               build_binary_op (GE_EXPR, gnu_expr_type,
3084                                                convert (gnu_expr_type,
3085                                                         gnu_max_expr),
3086                                                convert (gnu_expr_type,
3087                                                         gnu_min_expr)),
3088                               gnu_expr, gnu_min_expr));
3089           }
3090         else
3091           gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
3092
3093         gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
3094                                       gnu_result, gnu_expr);
3095       }
3096       break;
3097
3098     case N_Selected_Component:
3099       {
3100         tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
3101         Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
3102         Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
3103         tree gnu_field;
3104
3105         while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
3106                || IN (Ekind (gnat_pref_type), Access_Kind))
3107           {
3108             if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
3109               gnat_pref_type = Underlying_Type (gnat_pref_type);
3110             else if (IN (Ekind (gnat_pref_type), Access_Kind))
3111               gnat_pref_type = Designated_Type (gnat_pref_type);
3112           }
3113
3114         gnu_prefix = maybe_implicit_deref (gnu_prefix);
3115
3116         /* For discriminant references in tagged types always substitute the
3117            corresponding discriminant as the actual selected component. */
3118
3119         if (Is_Tagged_Type (gnat_pref_type))
3120           while (Present (Corresponding_Discriminant (gnat_field)))
3121             gnat_field = Corresponding_Discriminant (gnat_field);
3122
3123         /* For discriminant references of untagged types always substitute the
3124            corresponding stored discriminant. */
3125
3126         else if (Present (Corresponding_Discriminant (gnat_field)))
3127           gnat_field = Original_Record_Component (gnat_field);
3128
3129         /* Handle extracting the real or imaginary part of a complex.
3130            The real part is the first field and the imaginary the last.  */
3131
3132         if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
3133           gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
3134                                        ? REALPART_EXPR : IMAGPART_EXPR,
3135                                        NULL_TREE, gnu_prefix);
3136         else
3137           {
3138             gnu_field = gnat_to_gnu_field_decl (gnat_field);
3139
3140             /* If there are discriminants, the prefix might be
3141                evaluated more than once, which is a problem if it has
3142                side-effects. */
3143             if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
3144                                    ? Designated_Type (Etype
3145                                                       (Prefix (gnat_node)))
3146                                    : Etype (Prefix (gnat_node))))
3147               gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
3148
3149             gnu_result
3150               = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
3151                                      (Nkind (Parent (gnat_node))
3152                                       == N_Attribute_Reference));
3153           }
3154
3155         gcc_assert (gnu_result);
3156         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3157       }
3158       break;
3159
3160     case N_Attribute_Reference:
3161       {
3162         /* The attribute designator (like an enumeration value). */
3163         int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
3164
3165         /* The Elab_Spec and Elab_Body attributes are special in that
3166            Prefix is a unit, not an object with a GCC equivalent.  Similarly
3167            for Elaborated, since that variable isn't otherwise known.  */
3168         if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
3169           return (create_subprog_decl
3170                   (create_concat_name (Entity (Prefix (gnat_node)),
3171                                        attribute == Attr_Elab_Body
3172                                        ? "elabb" : "elabs"),
3173                    NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL,
3174                    gnat_node));
3175
3176         gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute);
3177       }
3178       break;
3179
3180     case N_Reference:
3181       /* Like 'Access as far as we are concerned.  */
3182       gnu_result = gnat_to_gnu (Prefix (gnat_node));
3183       gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
3184       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3185       break;
3186
3187     case N_Aggregate:
3188     case N_Extension_Aggregate:
3189       {
3190         tree gnu_aggr_type;
3191
3192         /* ??? It is wrong to evaluate the type now, but there doesn't
3193            seem to be any other practical way of doing it.  */
3194
3195         gcc_assert (!Expansion_Delayed (gnat_node));
3196
3197         gnu_aggr_type = gnu_result_type
3198           = get_unpadded_type (Etype (gnat_node));
3199
3200         if (TREE_CODE (gnu_result_type) == RECORD_TYPE
3201             && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
3202           gnu_aggr_type
3203             = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
3204
3205         if (Null_Record_Present (gnat_node))
3206           gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
3207
3208         else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
3209                  || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
3210           gnu_result
3211             = assoc_to_constructor (Etype (gnat_node),
3212                                     First (Component_Associations (gnat_node)),
3213                                     gnu_aggr_type);
3214         else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
3215           gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
3216                                            gnu_aggr_type,
3217                                            Component_Type (Etype (gnat_node)));
3218         else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
3219           gnu_result
3220             = build_binary_op
3221               (COMPLEX_EXPR, gnu_aggr_type,
3222                gnat_to_gnu (Expression (First
3223                                         (Component_Associations (gnat_node)))),
3224                gnat_to_gnu (Expression
3225                             (Next
3226                              (First (Component_Associations (gnat_node))))));
3227         else
3228           gcc_unreachable ();
3229
3230         gnu_result = convert (gnu_result_type, gnu_result);
3231       }
3232       break;
3233
3234     case N_Null:
3235       gnu_result = null_pointer_node;
3236       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3237       break;
3238
3239     case N_Type_Conversion:
3240     case N_Qualified_Expression:
3241       /* Get the operand expression.  */
3242       gnu_result = gnat_to_gnu (Expression (gnat_node));
3243       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3244
3245       gnu_result
3246         = convert_with_check (Etype (gnat_node), gnu_result,
3247                               Do_Overflow_Check (gnat_node),
3248                               Do_Range_Check (Expression (gnat_node)),
3249                               Nkind (gnat_node) == N_Type_Conversion
3250                               && Float_Truncate (gnat_node));
3251       break;
3252
3253     case N_Unchecked_Type_Conversion:
3254       gnu_result = gnat_to_gnu (Expression (gnat_node));
3255       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3256
3257       /* If the result is a pointer type, see if we are improperly
3258          converting to a stricter alignment.  */
3259
3260       if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
3261           && IN (Ekind (Etype (gnat_node)), Access_Kind))
3262         {
3263           unsigned int align = known_alignment (gnu_result);
3264           tree gnu_obj_type = TREE_TYPE (gnu_result_type);
3265           unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
3266
3267           if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
3268             post_error_ne_tree_2
3269               ("?source alignment (^) '< alignment of & (^)",
3270                gnat_node, Designated_Type (Etype (gnat_node)),
3271                size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
3272         }
3273
3274       gnu_result = unchecked_convert (gnu_result_type, gnu_result,
3275                                       No_Truncation (gnat_node));
3276       break;
3277
3278     case N_In:
3279     case N_Not_In:
3280       {
3281         tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
3282         Node_Id gnat_range = Right_Opnd (gnat_node);
3283         tree gnu_low;
3284         tree gnu_high;
3285
3286         /* GNAT_RANGE is either an N_Range node or an identifier
3287            denoting a subtype.  */
3288         if (Nkind (gnat_range) == N_Range)
3289           {
3290             gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
3291             gnu_high = gnat_to_gnu (High_Bound (gnat_range));
3292           }
3293         else if (Nkind (gnat_range) == N_Identifier
3294               || Nkind (gnat_range) == N_Expanded_Name)
3295           {
3296             tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
3297
3298             gnu_low = TYPE_MIN_VALUE (gnu_range_type);
3299             gnu_high = TYPE_MAX_VALUE (gnu_range_type);
3300           }
3301         else
3302           gcc_unreachable ();
3303
3304         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3305
3306         /* If LOW and HIGH are identical, perform an equality test.
3307            Otherwise, ensure that GNU_OBJECT is only evaluated once
3308            and perform a full range test.  */
3309         if (operand_equal_p (gnu_low, gnu_high, 0))
3310           gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
3311                                         gnu_object, gnu_low);
3312         else
3313           {
3314             gnu_object = protect_multiple_eval (gnu_object);
3315             gnu_result
3316               = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
3317                                  build_binary_op (GE_EXPR, gnu_result_type,
3318                                                   gnu_object, gnu_low),
3319                                  build_binary_op (LE_EXPR, gnu_result_type,
3320                                                   gnu_object, gnu_high));
3321           }
3322
3323         if (Nkind (gnat_node) == N_Not_In)
3324           gnu_result = invert_truthvalue (gnu_result);
3325       }
3326       break;
3327
3328     case N_Op_Divide:
3329       gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3330       gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3331       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3332       gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
3333                                     ? RDIV_EXPR
3334                                     : (Rounded_Result (gnat_node)
3335                                        ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
3336                                     gnu_result_type, gnu_lhs, gnu_rhs);
3337       break;
3338
3339     case N_Op_Or:    case N_Op_And:      case N_Op_Xor:
3340       /* These can either be operations on booleans or on modular types.
3341          Fall through for boolean types since that's the way GNU_CODES is
3342          set up.  */
3343       if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
3344               Modular_Integer_Kind))
3345         {
3346           enum tree_code code
3347             = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
3348                : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
3349                : BIT_XOR_EXPR);
3350
3351           gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3352           gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3353           gnu_result_type = get_unpadded_type (Etype (gnat_node));
3354           gnu_result = build_binary_op (code, gnu_result_type,
3355                                         gnu_lhs, gnu_rhs);
3356           break;
3357         }
3358
3359       /* ... fall through ... */
3360
3361     case N_Op_Eq:    case N_Op_Ne:       case N_Op_Lt:
3362     case N_Op_Le:    case N_Op_Gt:       case N_Op_Ge:
3363     case N_Op_Add:   case N_Op_Subtract: case N_Op_Multiply:
3364     case N_Op_Mod:   case N_Op_Rem:
3365     case N_Op_Rotate_Left:
3366     case N_Op_Rotate_Right:
3367     case N_Op_Shift_Left:
3368     case N_Op_Shift_Right:
3369     case N_Op_Shift_Right_Arithmetic:
3370     case N_And_Then: case N_Or_Else:
3371       {
3372         enum tree_code code = gnu_codes[Nkind (gnat_node)];
3373         bool ignore_lhs_overflow = false;
3374         tree gnu_type;
3375
3376         gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3377         gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3378         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3379
3380         /* If this is a comparison operator, convert any references to
3381            an unconstrained array value into a reference to the
3382            actual array.  */
3383         if (TREE_CODE_CLASS (code) == tcc_comparison)
3384           {
3385             gnu_lhs = maybe_unconstrained_array (gnu_lhs);
3386             gnu_rhs = maybe_unconstrained_array (gnu_rhs);
3387           }
3388
3389         /* If the result type is a private type, its full view may be a
3390            numeric subtype. The representation we need is that of its base
3391            type, given that it is the result of an arithmetic operation.  */
3392         else if (Is_Private_Type (Etype (gnat_node)))
3393           gnu_type = gnu_result_type
3394             = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
3395
3396         /* If this is a shift whose count is not guaranteed to be correct,
3397            we need to adjust the shift count.  */
3398         if (IN (Nkind (gnat_node), N_Op_Shift)
3399             && !Shift_Count_OK (gnat_node))
3400           {
3401             tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
3402             tree gnu_max_shift
3403               = convert (gnu_count_type, TYPE_SIZE (gnu_type));
3404
3405             if (Nkind (gnat_node) == N_Op_Rotate_Left
3406                 || Nkind (gnat_node) == N_Op_Rotate_Right)
3407               gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
3408                                          gnu_rhs, gnu_max_shift);
3409             else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
3410               gnu_rhs
3411                 = build_binary_op
3412                   (MIN_EXPR, gnu_count_type,
3413                    build_binary_op (MINUS_EXPR,
3414                                     gnu_count_type,
3415                                     gnu_max_shift,
3416                                     convert (gnu_count_type,
3417                                              integer_one_node)),
3418                    gnu_rhs);
3419           }
3420
3421         /* For right shifts, the type says what kind of shift to do,
3422            so we may need to choose a different type.  In this case,
3423            we have to ignore integer overflow lest it propagates all
3424            the way down and causes a CE to be explicitly raised.  */
3425         if (Nkind (gnat_node) == N_Op_Shift_Right
3426             && !TYPE_UNSIGNED (gnu_type))
3427           {
3428             gnu_type = gnat_unsigned_type (gnu_type);
3429             ignore_lhs_overflow = true;
3430           }
3431         else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
3432                  && TYPE_UNSIGNED (gnu_type))
3433           {
3434             gnu_type = gnat_signed_type (gnu_type);
3435             ignore_lhs_overflow = true;
3436           }
3437
3438         if (gnu_type != gnu_result_type)
3439           {
3440             tree gnu_old_lhs = gnu_lhs;
3441             gnu_lhs = convert (gnu_type, gnu_lhs);
3442             if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
3443               TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
3444             gnu_rhs = convert (gnu_type, gnu_rhs);
3445           }
3446
3447         gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
3448
3449         /* If this is a logical shift with the shift count not verified,
3450            we must return zero if it is too large.  We cannot compensate
3451            above in this case.  */
3452         if ((Nkind (gnat_node) == N_Op_Shift_Left
3453              || Nkind (gnat_node) == N_Op_Shift_Right)
3454             && !Shift_Count_OK (gnat_node))
3455           gnu_result
3456             = build_cond_expr
3457               (gnu_type,
3458                build_binary_op (GE_EXPR, integer_type_node,
3459                                 gnu_rhs,
3460                                 convert (TREE_TYPE (gnu_rhs),
3461                                          TYPE_SIZE (gnu_type))),
3462                convert (gnu_type, integer_zero_node),
3463                gnu_result);
3464       }
3465       break;
3466
3467     case N_Conditional_Expression:
3468       {
3469         tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
3470         tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
3471         tree gnu_false
3472           = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
3473
3474         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3475         gnu_result = build_cond_expr (gnu_result_type,
3476                                       gnat_truthvalue_conversion (gnu_cond),
3477                                       gnu_true, gnu_false);
3478       }
3479       break;
3480
3481     case N_Op_Plus:
3482       gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
3483       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3484       break;
3485
3486     case N_Op_Not:
3487       /* This case can apply to a boolean or a modular type.
3488          Fall through for a boolean operand since GNU_CODES is set
3489          up to handle this.  */
3490       if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
3491         {
3492           gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
3493           gnu_result_type = get_unpadded_type (Etype (gnat_node));
3494           gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
3495                                        gnu_expr);
3496           break;
3497         }
3498
3499       /* ... fall through ... */
3500
3501     case N_Op_Minus:  case N_Op_Abs:
3502       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
3503
3504       if (Ekind (Etype (gnat_node)) != E_Private_Type)
3505          gnu_result_type = get_unpadded_type (Etype (gnat_node));
3506       else
3507          gnu_result_type = get_unpadded_type (Base_Type
3508                                               (Full_View (Etype (gnat_node))));
3509
3510       gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
3511                                    gnu_result_type, gnu_expr);
3512       break;
3513
3514     case N_Allocator:
3515       {
3516         tree gnu_init = 0;
3517         tree gnu_type;
3518         bool ignore_init_type = false;
3519
3520         gnat_temp = Expression (gnat_node);
3521
3522         /* The Expression operand can either be an N_Identifier or
3523            Expanded_Name, which must represent a type, or a
3524            N_Qualified_Expression, which contains both the object type and an
3525            initial value for the object.  */
3526         if (Nkind (gnat_temp) == N_Identifier
3527             || Nkind (gnat_temp) == N_Expanded_Name)
3528           gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
3529         else if (Nkind (gnat_temp) == N_Qualified_Expression)
3530           {
3531             Entity_Id gnat_desig_type
3532               = Designated_Type (Underlying_Type (Etype (gnat_node)));
3533
3534             ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
3535             gnu_init = gnat_to_gnu (Expression (gnat_temp));
3536
3537             gnu_init = maybe_unconstrained_array (gnu_init);
3538             if (Do_Range_Check (Expression (gnat_temp)))
3539               gnu_init = emit_range_check (gnu_init, gnat_desig_type);
3540
3541             if (Is_Elementary_Type (gnat_desig_type)
3542                 || Is_Constrained (gnat_desig_type))
3543               {
3544                 gnu_type = gnat_to_gnu_type (gnat_desig_type);
3545                 gnu_init = convert (gnu_type, gnu_init);
3546               }
3547             else
3548               {
3549                 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
3550                 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
3551                   gnu_type = TREE_TYPE (gnu_init);
3552
3553                 gnu_init = convert (gnu_type, gnu_init);
3554               }
3555           }
3556         else
3557           gcc_unreachable ();
3558
3559         gnu_result_type = get_unpadded_type (Etype (gnat_node));
3560         return build_allocator (gnu_type, gnu_init, gnu_result_type,
3561                                 Procedure_To_Call (gnat_node),
3562                                 Storage_Pool (gnat_node), gnat_node,
3563                                 ignore_init_type);
3564       }
3565       break;
3566
3567     /***************************/
3568     /* Chapter 5: Statements:  */
3569     /***************************/
3570
3571     case N_Label:
3572       gnu_result = build1 (LABEL_EXPR, void_type_node,
3573                            gnat_to_gnu (Identifier (gnat_node)));
3574       break;
3575
3576     case N_Null_Statement:
3577       gnu_result = alloc_stmt_list ();
3578       break;
3579
3580     case N_Assignment_Statement:
3581       /* Get the LHS and RHS of the statement and convert any reference to an
3582          unconstrained array into a reference to the underlying array.
3583          If we are not to do range checking and the RHS is an N_Function_Call,
3584          pass the LHS to the call function.  */
3585       gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
3586
3587       /* If the type has a size that overflows, convert this into raise of
3588          Storage_Error: execution shouldn't have gotten here anyway.  */
3589       if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
3590            && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
3591         gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node);
3592       else if (Nkind (Expression (gnat_node)) == N_Function_Call
3593                && !Do_Range_Check (Expression (gnat_node)))
3594         gnu_result = call_to_gnu (Expression (gnat_node),
3595                                   &gnu_result_type, gnu_lhs);
3596       else
3597         {
3598           gnu_rhs
3599             = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
3600
3601           /* If range check is needed, emit code to generate it */
3602           if (Do_Range_Check (Expression (gnat_node)))
3603             gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
3604
3605           gnu_result
3606             = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
3607         }
3608       break;
3609
3610     case N_If_Statement:
3611       {
3612         tree *gnu_else_ptr;     /* Point to put next "else if" or "else". */
3613
3614         /* Make the outer COND_EXPR.  Avoid non-determinism.  */
3615         gnu_result = build3 (COND_EXPR, void_type_node,
3616                              gnat_to_gnu (Condition (gnat_node)),
3617                              NULL_TREE, NULL_TREE);
3618         COND_EXPR_THEN (gnu_result)
3619           = build_stmt_group (Then_Statements (gnat_node), false);
3620         TREE_SIDE_EFFECTS (gnu_result) = 1;
3621         gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
3622
3623         /* Now make a COND_EXPR for each of the "else if" parts.  Put each
3624            into the previous "else" part and point to where to put any
3625            outer "else".  Also avoid non-determinism.  */
3626         if (Present (Elsif_Parts (gnat_node)))
3627           for (gnat_temp = First (Elsif_Parts (gnat_node));
3628                Present (gnat_temp); gnat_temp = Next (gnat_temp))
3629             {
3630               gnu_expr = build3 (COND_EXPR, void_type_node,
3631                                  gnat_to_gnu (Condition (gnat_temp)),
3632                                  NULL_TREE, NULL_TREE);
3633               COND_EXPR_THEN (gnu_expr)
3634                 = build_stmt_group (Then_Statements (gnat_temp), false);
3635               TREE_SIDE_EFFECTS (gnu_expr) = 1;
3636               annotate_with_node (gnu_expr, gnat_temp);
3637               *gnu_else_ptr = gnu_expr;
3638               gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3639             }
3640
3641         *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
3642       }
3643       break;
3644
3645     case N_Case_Statement:
3646       gnu_result = Case_Statement_to_gnu (gnat_node);
3647       break;
3648
3649     case N_Loop_Statement:
3650       gnu_result = Loop_Statement_to_gnu (gnat_node);
3651       break;
3652
3653     case N_Block_Statement:
3654       start_stmt_group ();
3655       gnat_pushlevel ();
3656       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3657       add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3658       gnat_poplevel ();
3659       gnu_result = end_stmt_group ();
3660
3661       if (Present (Identifier (gnat_node)))
3662         mark_out_of_scope (Entity (Identifier (gnat_node)));
3663       break;
3664
3665     case N_Exit_Statement:
3666       gnu_result
3667         = build2 (EXIT_STMT, void_type_node,
3668                   (Present (Condition (gnat_node))
3669                    ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
3670                   (Present (Name (gnat_node))
3671                    ? get_gnu_tree (Entity (Name (gnat_node)))
3672                    : TREE_VALUE (gnu_loop_label_stack)));
3673       break;
3674
3675     case N_Return_Statement:
3676       {
3677         /* The gnu function type of the subprogram currently processed.  */
3678         tree gnu_subprog_type = TREE_TYPE (current_function_decl);
3679         /* The return value from the subprogram.  */
3680         tree gnu_ret_val = NULL_TREE;
3681         /* The place to put the return value.  */
3682         tree gnu_lhs;
3683
3684         /* If we are dealing with a "return;" from an Ada procedure with
3685            parameters passed by copy in copy out, we need to return a record
3686            containing the final values of these parameters.  If the list
3687            contains only one entry, return just that entry.
3688
3689            For a full description of the copy in copy out parameter mechanism,
3690            see the part of the gnat_to_gnu_entity routine dealing with the
3691            translation of subprograms.
3692
3693            But if we have a return label defined, convert this into
3694            a branch to that label.  */
3695
3696         if (TREE_VALUE (gnu_return_label_stack))
3697           {
3698             gnu_result = build1 (GOTO_EXPR, void_type_node,
3699                                  TREE_VALUE (gnu_return_label_stack));
3700             break;
3701           }
3702
3703         else if (TYPE_CI_CO_LIST (gnu_subprog_type))
3704           {
3705             gnu_lhs = DECL_RESULT (current_function_decl);
3706             if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
3707               gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
3708             else
3709               gnu_ret_val
3710                 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
3711                                           TYPE_CI_CO_LIST (gnu_subprog_type));
3712           }
3713
3714         /* If the Ada subprogram is a function, we just need to return the
3715            expression.   If the subprogram returns an unconstrained
3716            array, we have to allocate a new version of the result and
3717            return it.  If we return by reference, return a pointer.  */
3718
3719         else if (Present (Expression (gnat_node)))
3720           {
3721             /* If the current function returns by target pointer and we
3722                are doing a call, pass that target to the call.  */
3723             if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
3724                 && Nkind (Expression (gnat_node)) == N_Function_Call)
3725               {
3726                 gnu_lhs
3727                   = build_unary_op (INDIRECT_REF, NULL_TREE,
3728                                     DECL_ARGUMENTS (current_function_decl));
3729                 gnu_result = call_to_gnu (Expression (gnat_node),
3730                                           &gnu_result_type, gnu_lhs);
3731               }
3732             else
3733               {
3734                 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
3735
3736                 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
3737                   /* The original return type was unconstrained so dereference
3738                      the TARGET pointer in the actual return value's type. */
3739                   gnu_lhs
3740                     = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
3741                                       DECL_ARGUMENTS (current_function_decl));
3742                 else
3743                   gnu_lhs = DECL_RESULT (current_function_decl);
3744
3745                 /* Do not remove the padding from GNU_RET_VAL if the inner
3746                    type is self-referential since we want to allocate the fixed
3747                    size in that case.  */
3748                 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
3749                     && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
3750                         == RECORD_TYPE)
3751                     && (TYPE_IS_PADDING_P
3752                         (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
3753                     && (CONTAINS_PLACEHOLDER_P
3754                         (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
3755                   gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
3756
3757                 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
3758                     || By_Ref (gnat_node))
3759                   gnu_ret_val
3760                     = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
3761
3762                 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
3763                   {
3764                     gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
3765
3766                     /* We have two cases: either the function returns with
3767                        depressed stack or not.  If not, we allocate on the
3768                        secondary stack.  If so, we allocate in the stack frame.
3769                        if no copy is needed, the front end will set By_Ref,
3770                        which we handle in the case above.  */
3771                     if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
3772                       gnu_ret_val
3773                         = build_allocator (TREE_TYPE (gnu_ret_val),
3774                                            gnu_ret_val,
3775                                            TREE_TYPE (gnu_subprog_type),
3776                                            0, -1, gnat_node, false);
3777                     else
3778                       gnu_ret_val
3779                         = build_allocator (TREE_TYPE (gnu_ret_val),
3780                                            gnu_ret_val,
3781                                            TREE_TYPE (gnu_subprog_type),
3782                                            Procedure_To_Call (gnat_node),
3783                                            Storage_Pool (gnat_node),
3784                                            gnat_node, false);
3785                   }
3786               }
3787           }
3788         else
3789           /* If the Ada subprogram is a regular procedure, just return.  */
3790           gnu_lhs = NULL_TREE;
3791
3792         if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
3793           {
3794             if (gnu_ret_val)
3795               gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3796                                             gnu_lhs, gnu_ret_val);
3797             add_stmt_with_node (gnu_result, gnat_node);
3798             gnu_lhs = NULL_TREE;
3799           }
3800
3801         gnu_result = build_return_expr (gnu_lhs, gnu_ret_val);
3802       }
3803       break;
3804
3805     case N_Goto_Statement:
3806       gnu_result = build1 (GOTO_EXPR, void_type_node,
3807                            gnat_to_gnu (Name (gnat_node)));
3808       break;
3809
3810     /****************************/
3811     /* Chapter 6: Subprograms:  */
3812     /****************************/
3813
3814     case N_Subprogram_Declaration:
3815       /* Unless there is a freeze node, declare the subprogram.  We consider
3816          this a "definition" even though we're not generating code for
3817          the subprogram because we will be making the corresponding GCC
3818          node here.  */
3819
3820       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
3821         gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
3822                             NULL_TREE, 1);
3823       gnu_result = alloc_stmt_list ();
3824       break;
3825
3826     case N_Abstract_Subprogram_Declaration:
3827       /* This subprogram doesn't exist for code generation purposes, but we
3828          have to elaborate the types of any parameters and result, unless
3829          they are imported types (nothing to generate in this case).  */
3830
3831       /* Process the parameter types first.  */
3832
3833       for (gnat_temp
3834            = First_Formal_With_Extras
3835                (Defining_Entity (Specification (gnat_node)));
3836            Present (gnat_temp);
3837            gnat_temp = Next_Formal_With_Extras (gnat_temp))
3838         if (Is_Itype (Etype (gnat_temp))
3839             && !From_With_Type (Etype (gnat_temp)))
3840           gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3841
3842
3843       /* Then the result type, set to Standard_Void_Type for procedures.  */
3844
3845       {
3846         Entity_Id gnat_temp_type
3847           = Etype (Defining_Entity (Specification (gnat_node)));
3848
3849         if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
3850           gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
3851       }
3852
3853       gnu_result = alloc_stmt_list ();
3854       break;
3855
3856     case N_Defining_Program_Unit_Name:
3857       /* For a child unit identifier go up a level to get the
3858          specification.  We get this when we try to find the spec of
3859          a child unit package that is the compilation unit being compiled. */
3860       gnu_result = gnat_to_gnu (Parent (gnat_node));
3861       break;
3862
3863     case N_Subprogram_Body:
3864       Subprogram_Body_to_gnu (gnat_node);
3865       gnu_result = alloc_stmt_list ();
3866       break;
3867
3868     case N_Function_Call:
3869     case N_Procedure_Call_Statement:
3870       gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
3871       break;
3872
3873     /*************************/
3874     /* Chapter 7: Packages:  */
3875     /*************************/
3876
3877     case N_Package_Declaration:
3878       gnu_result = gnat_to_gnu (Specification (gnat_node));
3879       break;
3880
3881     case N_Package_Specification:
3882
3883       start_stmt_group ();
3884       process_decls (Visible_Declarations (gnat_node),
3885                      Private_Declarations (gnat_node), Empty, true, true);
3886       gnu_result = end_stmt_group ();
3887       break;
3888
3889     case N_Package_Body:
3890
3891       /* If this is the body of a generic package - do nothing */
3892       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
3893         {
3894           gnu_result = alloc_stmt_list ();
3895           break;
3896         }
3897
3898       start_stmt_group ();
3899       process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3900
3901       if (Present (Handled_Statement_Sequence (gnat_node)))
3902         add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3903
3904       gnu_result = end_stmt_group ();
3905       break;
3906
3907     /*********************************/
3908     /* Chapter 8: Visibility Rules:  */
3909     /*********************************/
3910
3911     case N_Use_Package_Clause:
3912     case N_Use_Type_Clause:
3913       /* Nothing to do here - but these may appear in list of declarations */
3914       gnu_result = alloc_stmt_list ();
3915       break;
3916
3917     /***********************/
3918     /* Chapter 9: Tasks:   */
3919     /***********************/
3920
3921     case N_Protected_Type_Declaration:
3922       gnu_result = alloc_stmt_list ();
3923       break;
3924
3925     case N_Single_Task_Declaration:
3926       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3927       gnu_result = alloc_stmt_list ();
3928       break;
3929
3930     /***********************************************************/
3931     /* Chapter 10: Program Structure and Compilation Issues:   */
3932     /***********************************************************/
3933
3934     case N_Compilation_Unit:
3935
3936       /* This is not called for the main unit, which is handled in function
3937          gigi above.  */
3938       start_stmt_group ();
3939       gnat_pushlevel ();
3940
3941       Compilation_Unit_to_gnu (gnat_node);
3942       gnu_result = alloc_stmt_list ();
3943       break;
3944
3945     case N_Subprogram_Body_Stub:
3946     case N_Package_Body_Stub:
3947     case N_Protected_Body_Stub:
3948     case N_Task_Body_Stub:
3949       /* Simply process whatever unit is being inserted.  */
3950       gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
3951       break;
3952
3953     case N_Subunit:
3954       gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
3955       break;
3956
3957     /***************************/
3958     /* Chapter 11: Exceptions: */
3959     /***************************/
3960
3961     case N_Handled_Sequence_Of_Statements:
3962       /* If there is an At_End procedure attached to this node, and the EH
3963          mechanism is SJLJ, we must have at least a corresponding At_End
3964          handler, unless the No_Exception_Handlers restriction is set.  */
3965       gcc_assert (type_annotate_only
3966                   || Exception_Mechanism != Setjmp_Longjmp
3967                   || No (At_End_Proc (gnat_node))
3968                   || Present (Exception_Handlers (gnat_node))
3969                   || No_Exception_Handlers_Set ());
3970
3971       gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
3972       break;
3973
3974     case N_Exception_Handler:
3975       if (Exception_Mechanism == Setjmp_Longjmp)
3976         gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
3977       else if (Exception_Mechanism == Back_End_Exceptions)
3978         gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
3979       else
3980         gcc_unreachable ();
3981
3982       break;
3983
3984     /*******************************/
3985     /* Chapter 12: Generic Units:  */
3986     /*******************************/
3987
3988     case N_Generic_Function_Renaming_Declaration:
3989     case N_Generic_Package_Renaming_Declaration:
3990     case N_Generic_Procedure_Renaming_Declaration:
3991     case N_Generic_Package_Declaration:
3992     case N_Generic_Subprogram_Declaration:
3993     case N_Package_Instantiation:
3994     case N_Procedure_Instantiation:
3995     case N_Function_Instantiation:
3996       /* These nodes can appear on a declaration list but there is nothing to
3997          to be done with them.  */
3998       gnu_result = alloc_stmt_list ();
3999       break;
4000
4001     /***************************************************/
4002     /* Chapter 13: Representation Clauses and          */
4003     /*             Implementation-Dependent Features:  */
4004     /***************************************************/
4005
4006     case N_Attribute_Definition_Clause:
4007
4008       gnu_result = alloc_stmt_list ();
4009
4010       /* The only one we need deal with is for 'Address.  For the others, SEM
4011          puts the information elsewhere.  We need only deal with 'Address
4012          if the object has a Freeze_Node (which it never will currently).  */
4013       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
4014           || No (Freeze_Node (Entity (Name (gnat_node)))))
4015         break;
4016
4017       /* Get the value to use as the address and save it as the
4018          equivalent for GNAT_TEMP.  When the object is frozen,
4019          gnat_to_gnu_entity will do the right thing. */
4020       save_gnu_tree (Entity (Name (gnat_node)),
4021                      gnat_to_gnu (Expression (gnat_node)), true);
4022       break;
4023
4024     case N_Enumeration_Representation_Clause:
4025     case N_Record_Representation_Clause:
4026     case N_At_Clause:
4027       /* We do nothing with these.  SEM puts the information elsewhere.  */
4028       gnu_result = alloc_stmt_list ();
4029       break;
4030
4031     case N_Code_Statement:
4032       if (!type_annotate_only)
4033         {
4034           tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
4035           tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
4036           tree gnu_clobbers = NULL_TREE, tail;
4037           bool allows_mem, allows_reg, fake;
4038           int ninputs, noutputs, i;
4039           const char **oconstraints;
4040           const char *constraint;
4041           char *clobber;
4042
4043           /* First retrieve the 3 operand lists built by the front-end.  */
4044           Setup_Asm_Outputs (gnat_node);
4045           while (Present (gnat_temp = Asm_Output_Variable ()))
4046             {
4047               tree gnu_value = gnat_to_gnu (gnat_temp);
4048               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
4049                                                  (Asm_Output_Constraint ()));
4050
4051               gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
4052               Next_Asm_Output ();
4053             }
4054
4055           Setup_Asm_Inputs (gnat_node);
4056           while (Present (gnat_temp = Asm_Input_Value ()))
4057             {
4058               tree gnu_value = gnat_to_gnu (gnat_temp);
4059               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
4060                                                  (Asm_Input_Constraint ()));
4061
4062               gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
4063               Next_Asm_Input ();
4064             }
4065
4066           Clobber_Setup (gnat_node);
4067           while ((clobber = Clobber_Get_Next ()))
4068             gnu_clobbers
4069               = tree_cons (NULL_TREE,
4070                            build_string (strlen (clobber) + 1, clobber),
4071                            gnu_clobbers);
4072
4073           /* Then perform some standard checking and processing on the
4074              operands.  In particular, mark them addressable if needed.  */
4075           gnu_outputs = nreverse (gnu_outputs);
4076           noutputs = list_length (gnu_outputs);
4077           gnu_inputs = nreverse (gnu_inputs);
4078           ninputs = list_length (gnu_inputs);
4079           oconstraints
4080             = (const char **) alloca (noutputs * sizeof (const char *));
4081
4082           for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
4083             {
4084               tree output = TREE_VALUE (tail);
4085               constraint
4086                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
4087               oconstraints[i] = constraint;
4088
4089               if (parse_output_constraint (&constraint, i, ninputs, noutputs,
4090                                            &allows_mem, &allows_reg, &fake))
4091                 {
4092                   /* If the operand is going to end up in memory,
4093                      mark it addressable.  Note that we don't test
4094                      allows_mem like in the input case below; this
4095                      is modelled on the C front-end.  */
4096                   if (!allows_reg
4097                       && !gnat_mark_addressable (output))
4098                     output = error_mark_node;
4099                 }
4100               else
4101                 output = error_mark_node;
4102
4103               TREE_VALUE (tail) = output;
4104             }
4105
4106           for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
4107             {
4108               tree input = TREE_VALUE (tail);
4109               constraint
4110                 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
4111
4112               if (parse_input_constraint (&constraint, i, ninputs, noutputs,
4113                                           0, oconstraints,
4114                                           &allows_mem, &allows_reg))
4115                 {
4116                   /* If the operand is going to end up in memory,
4117                      mark it addressable.  */
4118                   if (!allows_reg && allows_mem
4119                       && !gnat_mark_addressable (input))
4120                     input = error_mark_node;
4121                 }
4122               else
4123                 input = error_mark_node;
4124
4125               TREE_VALUE (tail) = input;
4126             }
4127
4128           gnu_result = build4 (ASM_EXPR,  void_type_node,
4129                                gnu_template, gnu_outputs,
4130                                gnu_inputs, gnu_clobbers);
4131           ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
4132         }
4133       else
4134         gnu_result = alloc_stmt_list ();
4135
4136       break;
4137
4138     /***************************************************/
4139     /* Added Nodes                                     */
4140     /***************************************************/
4141
4142     case N_Freeze_Entity:
4143       start_stmt_group ();
4144       process_freeze_entity (gnat_node);
4145       process_decls (Actions (gnat_node), Empty, Empty, true, true);
4146       gnu_result = end_stmt_group ();
4147       break;
4148
4149     case N_Itype_Reference:
4150       if (!present_gnu_tree (Itype (gnat_node)))
4151         process_type (Itype (gnat_node));
4152
4153       gnu_result = alloc_stmt_list ();
4154       break;
4155
4156     case N_Free_Statement:
4157       if (!type_annotate_only)
4158         {
4159           tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
4160           tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
4161           tree gnu_obj_type;
4162           tree gnu_actual_obj_type = 0;
4163           tree gnu_obj_size;
4164           int align;
4165
4166           /* If this is a thin pointer, we must dereference it to create
4167              a fat pointer, then go back below to a thin pointer.  The
4168              reason for this is that we need a fat pointer someplace in
4169              order to properly compute the size.  */
4170           if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
4171             gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
4172                                       build_unary_op (INDIRECT_REF, NULL_TREE,
4173                                                       gnu_ptr));
4174
4175           /* If this is an unconstrained array, we know the object must
4176              have been allocated with the template in front of the object.
4177              So pass the template address, but get the total size.  Do this
4178              by converting to a thin pointer.  */
4179           if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
4180             gnu_ptr
4181               = convert (build_pointer_type
4182                          (TYPE_OBJECT_RECORD_TYPE
4183                           (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
4184                          gnu_ptr);
4185
4186           gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
4187
4188           if (Present (Actual_Designated_Subtype (gnat_node)))
4189             {
4190               gnu_actual_obj_type
4191                 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
4192
4193               if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
4194                 gnu_actual_obj_type
4195                   = build_unc_object_type_from_ptr (gnu_ptr_type,
4196                       gnu_actual_obj_type,
4197                       get_identifier ("DEALLOC"));
4198             }
4199           else
4200             gnu_actual_obj_type = gnu_obj_type;
4201
4202           gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
4203           align = TYPE_ALIGN (gnu_obj_type);
4204
4205           if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
4206               && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
4207             {
4208               tree gnu_char_ptr_type = build_pointer_type (char_type_node);
4209               tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
4210               tree gnu_byte_offset
4211                 = convert (gnu_char_ptr_type,
4212                            size_diffop (size_zero_node, gnu_pos));
4213
4214               gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
4215               gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
4216                                          gnu_ptr, gnu_byte_offset);
4217             }
4218
4219           gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
4220                                                  Procedure_To_Call (gnat_node),
4221                                                  Storage_Pool (gnat_node),
4222                                                  gnat_node);
4223         }
4224       break;
4225
4226     case N_Raise_Constraint_Error:
4227     case N_Raise_Program_Error:
4228     case N_Raise_Storage_Error:
4229       if (type_annotate_only)
4230         {
4231           gnu_result = alloc_stmt_list ();
4232           break;
4233         }
4234
4235       gnu_result_type = get_unpadded_type (Etype (gnat_node));
4236       gnu_result
4237         = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node);
4238
4239       /* If the type is VOID, this is a statement, so we need to
4240          generate the code for the call.  Handle a Condition, if there
4241          is one.  */
4242       if (TREE_CODE (gnu_result_type) == VOID_TYPE)
4243         {
4244           annotate_with_node (gnu_result, gnat_node);
4245
4246           if (Present (Condition (gnat_node)))
4247             gnu_result = build3 (COND_EXPR, void_type_node,
4248                                  gnat_to_gnu (Condition (gnat_node)),
4249                                  gnu_result, alloc_stmt_list ());
4250         }
4251       else
4252         gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
4253       break;
4254
4255     case N_Validate_Unchecked_Conversion:
4256       /* If the result is a pointer type, see if we are either converting
4257          from a non-pointer or from a pointer to a type with a different
4258          alias set and warn if so.  If the result defined in the same unit as
4259          this unchecked conversion, we can allow this because we can know to
4260          make that type have alias set 0.  */
4261       {
4262         tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
4263         tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
4264
4265         if (POINTER_TYPE_P (gnu_target_type)
4266             && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node)
4267             && get_alias_set (TREE_TYPE (gnu_target_type)) != 0
4268             && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node)))
4269             && (!POINTER_TYPE_P (gnu_source_type)
4270                 || (get_alias_set (TREE_TYPE (gnu_source_type))
4271                     != get_alias_set (TREE_TYPE (gnu_target_type)))))
4272           {
4273             post_error_ne
4274               ("?possible aliasing problem for type&",
4275                gnat_node, Target_Type (gnat_node));
4276             post_error
4277               ("\\?use -fno-strict-aliasing switch for references",
4278                gnat_node);
4279             post_error_ne
4280               ("\\?or use `pragma No_Strict_Aliasing (&);`",
4281                gnat_node, Target_Type (gnat_node));
4282           }
4283
4284         /* The No_Strict_Aliasing flag is not propagated to the back-end for
4285            fat pointers so unconditionally warn in problematic cases.  */
4286         else if (TYPE_FAT_POINTER_P (gnu_target_type))
4287           {
4288             tree array_type
4289               = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
4290
4291             if (get_alias_set (array_type) != 0
4292                 && (!TYPE_FAT_POINTER_P (gnu_source_type)
4293                     || (get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))))
4294                         != get_alias_set (array_type))))
4295               {
4296                 post_error_ne
4297                   ("?possible aliasing problem for type&",
4298                    gnat_node, Target_Type (gnat_node));
4299                 post_error
4300                   ("\\?use -fno-strict-aliasing switch for references",
4301                    gnat_node);
4302               }
4303           }
4304       }
4305       gnu_result = alloc_stmt_list ();
4306       break;
4307
4308     case N_Raise_Statement:
4309     case N_Function_Specification:
4310     case N_Procedure_Specification:
4311     case N_Op_Concat:
4312     case N_Component_Association:
4313     case N_Task_Body:
4314     default:
4315       gcc_assert (type_annotate_only);
4316       gnu_result = alloc_stmt_list ();
4317     }
4318
4319   /* If we pushed our level as part of processing the elaboration routine,
4320      pop it back now.  */
4321   if (went_into_elab_proc)
4322     {
4323       add_stmt (gnu_result);
4324       gnat_poplevel ();
4325       gnu_result = end_stmt_group ();
4326       current_function_decl = NULL_TREE;
4327     }
4328
4329   /* Set the location information into the result.  Note that we may have
4330      no result if we tried to build a CALL_EXPR node to a procedure with
4331      no side-effects and optimization is enabled.  */
4332   if (gnu_result && EXPR_P (gnu_result))
4333     annotate_with_node (gnu_result, gnat_node);
4334
4335   /* If we're supposed to return something of void_type, it means we have
4336      something we're elaborating for effect, so just return.  */
4337   if (TREE_CODE (gnu_result_type) == VOID_TYPE)
4338     return gnu_result;
4339
4340   /* If the result is a constant that overflows, raise constraint error.  */
4341   else if (TREE_CODE (gnu_result) == INTEGER_CST
4342       && TREE_OVERFLOW (gnu_result))
4343     {
4344       post_error ("Constraint_Error will be raised at run-time?", gnat_node);
4345
4346       gnu_result
4347         = build1 (NULL_EXPR, gnu_result_type,
4348                   build_call_raise (CE_Overflow_Check_Failed, gnat_node));
4349     }
4350
4351   /* If our result has side-effects and is of an unconstrained type,
4352      make a SAVE_EXPR so that we can be sure it will only be referenced
4353      once.  Note we must do this before any conversions.  */
4354   if (TREE_SIDE_EFFECTS (gnu_result)
4355       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
4356           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
4357     gnu_result = gnat_stabilize_reference (gnu_result, false);
4358
4359   /* Now convert the result to the proper type.  If the type is void or if
4360      we have no result, return error_mark_node to show we have no result.
4361      If the type of the result is correct or if we have a label (which doesn't
4362      have any well-defined type), return our result.  Also don't do the
4363      conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4364      since those are the cases where the front end may have the type wrong due
4365      to "instantiating" the unconstrained record with discriminant values
4366      or if this is a FIELD_DECL.  If this is the Name of an assignment
4367      statement or a parameter of a procedure call, return what we have since
4368      the RHS has to be converted to our type there in that case, unless
4369      GNU_RESULT_TYPE has a simpler size.  Similarly, if the two types are
4370      record types with the same name, the expression type has integral mode,
4371      and GNU_RESULT_TYPE BLKmode, don't convert.  This will be the case when
4372      we are converting from a packable type to its actual type and we need
4373      those conversions to be NOPs in order for assignments into these types to
4374      work properly if the inner object is a bitfield and hence can't have
4375      its address taken.  Finally, don't convert integral types that are the
4376      operand of an unchecked conversion since we need to ignore those
4377      conversions (for 'Valid).  Otherwise, convert the result to the proper
4378      type.  */
4379
4380   if (Present (Parent (gnat_node))
4381       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
4382            && Name (Parent (gnat_node)) == gnat_node)
4383           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
4384               && Name (Parent (gnat_node)) != gnat_node)
4385           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
4386               && !AGGREGATE_TYPE_P (gnu_result_type)
4387               && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4388           || Nkind (Parent (gnat_node)) == N_Parameter_Association)
4389       && !(TYPE_SIZE (gnu_result_type)
4390            && TYPE_SIZE (TREE_TYPE (gnu_result))
4391            && (AGGREGATE_TYPE_P (gnu_result_type)
4392                == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4393            && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
4394                 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
4395                     != INTEGER_CST))
4396                || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4397                    && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
4398                    && (CONTAINS_PLACEHOLDER_P
4399                        (TYPE_SIZE (TREE_TYPE (gnu_result))))))
4400            && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
4401                 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
4402     {
4403       /* In this case remove padding only if the inner object is of
4404          self-referential size: in that case it must be an object of
4405          unconstrained type with a default discriminant.  In other cases,
4406          we want to avoid copying too much data.  */
4407       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4408           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
4409           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4410                                      (TREE_TYPE (TYPE_FIELDS
4411                                                  (TREE_TYPE (gnu_result))))))
4412         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4413                               gnu_result);
4414     }
4415
4416   else if (TREE_CODE (gnu_result) == LABEL_DECL
4417            || TREE_CODE (gnu_result) == FIELD_DECL
4418            || TREE_CODE (gnu_result) == ERROR_MARK
4419            || (TYPE_SIZE (gnu_result_type)
4420                && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4421                && TREE_CODE (gnu_result) != INDIRECT_REF
4422                && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
4423            || ((TYPE_NAME (gnu_result_type)
4424                 == TYPE_NAME (TREE_TYPE (gnu_result)))
4425                && TREE_CODE (gnu_result_type) == RECORD_TYPE
4426                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4427                && TYPE_MODE (gnu_result_type) == BLKmode
4428                && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
4429                    == MODE_INT)))
4430     {
4431       /* Remove any padding record, but do nothing more in this case.  */
4432       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4433           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4434         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4435                               gnu_result);
4436     }
4437
4438   else if (gnu_result == error_mark_node
4439            || gnu_result_type == void_type_node)
4440     gnu_result =  error_mark_node;
4441   else if (gnu_result_type != TREE_TYPE (gnu_result))
4442     gnu_result = convert (gnu_result_type, gnu_result);
4443
4444   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT.  */
4445   while ((TREE_CODE (gnu_result) == NOP_EXPR
4446           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
4447          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
4448     gnu_result = TREE_OPERAND (gnu_result, 0);
4449
4450   return gnu_result;
4451 }
4452 \f
4453 /* Record the current code position in GNAT_NODE.  */
4454
4455 static void
4456 record_code_position (Node_Id gnat_node)
4457 {
4458   tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
4459
4460   add_stmt_with_node (stmt_stmt, gnat_node);
4461   save_gnu_tree (gnat_node, stmt_stmt, true);
4462 }
4463
4464 /* Insert the code for GNAT_NODE at the position saved for that node.  */
4465
4466 static void
4467 insert_code_for (Node_Id gnat_node)
4468 {
4469   STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
4470   save_gnu_tree (gnat_node, NULL_TREE, true);
4471 }
4472 \f
4473 /* Start a new statement group chained to the previous group.  */
4474
4475 static void
4476 start_stmt_group ()
4477 {
4478   struct stmt_group *group = stmt_group_free_list;
4479
4480   /* First see if we can get one from the free list.  */
4481   if (group)
4482     stmt_group_free_list = group->previous;
4483   else
4484     group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group));
4485
4486   group->previous = current_stmt_group;
4487   group->stmt_list = group->block = group->cleanups = NULL_TREE;
4488   current_stmt_group = group;
4489 }
4490
4491 /* Add GNU_STMT to the current statement group.  */
4492
4493 void
4494 add_stmt (tree gnu_stmt)
4495 {
4496   append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
4497 }
4498
4499 /* Similar, but set the location of GNU_STMT to that of GNAT_NODE.  */
4500
4501 void
4502 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
4503 {
4504   if (Present (gnat_node))
4505     annotate_with_node (gnu_stmt, gnat_node);
4506   add_stmt (gnu_stmt);
4507 }
4508
4509 /* Add a declaration statement for GNU_DECL to the current statement group.
4510    Get SLOC from Entity_Id.  */
4511
4512 void
4513 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
4514 {
4515   tree type = TREE_TYPE (gnu_decl);
4516   tree gnu_stmt, gnu_init, gnu_lhs;
4517
4518   /* If this is a variable that Gigi is to ignore, we may have been given
4519      an ERROR_MARK.  So test for it.  We also might have been given a
4520      reference for a renaming.  So only do something for a decl.  Also
4521      ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE.  */
4522   if (!DECL_P (gnu_decl)
4523       || (TREE_CODE (gnu_decl) == TYPE_DECL
4524           && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
4525     return;
4526
4527   gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
4528
4529   /* If we are global, we don't want to actually output the DECL_EXPR for
4530      this decl since we already have evaluated the expressions in the
4531      sizes and positions as globals and doing it again would be wrong.  */
4532   if (global_bindings_p ())
4533     {
4534       /* Mark everything as used to prevent node sharing with subprograms.
4535          Note that walk_tree knows how to handle TYPE_DECL, but neither
4536          VAR_DECL nor CONST_DECL.  This appears to be somewhat arbitrary.  */
4537       walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
4538       if (TREE_CODE (gnu_decl) == VAR_DECL
4539           || TREE_CODE (gnu_decl) == CONST_DECL)
4540         {
4541           walk_tree (&DECL_SIZE (gnu_decl), mark_visited, NULL, NULL);
4542           walk_tree (&DECL_SIZE_UNIT (gnu_decl), mark_visited, NULL, NULL);
4543           walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL);
4544         }
4545     }
4546   else
4547     add_stmt_with_node (gnu_stmt, gnat_entity);
4548
4549   /* If this is a variable and an initializer is attached to it, it must be
4550      valid for the context.  Similar to init_const in create_var_decl_1.  */
4551   if (TREE_CODE (gnu_decl) == VAR_DECL
4552       && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
4553       && (TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (TREE_TYPE (gnu_init))
4554           || (TREE_STATIC (gnu_decl)
4555               && !initializer_constant_valid_p (gnu_init,
4556                                                 TREE_TYPE (gnu_init)))))
4557     {
4558       /* If GNU_DECL has a padded type, convert it to the unpadded
4559          type so the assignment is done properly.  */
4560       if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4561         gnu_lhs = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
4562       else
4563         gnu_lhs = gnu_decl;
4564
4565       gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_init);
4566
4567       DECL_INITIAL (gnu_decl) = NULL_TREE;
4568       if (TREE_READONLY (gnu_decl))
4569         {
4570           TREE_READONLY (gnu_decl) = 0;
4571           DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
4572         }
4573
4574       add_stmt_with_node (gnu_stmt, gnat_entity);
4575     }
4576 }
4577
4578 /* Utility function to mark nodes with TREE_VISITED and types as having their
4579    sized gimplified.  Called from walk_tree.  We use this to indicate all
4580    variable sizes and positions in global types may not be shared by any
4581    subprogram.  */
4582
4583 static tree
4584 mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
4585 {
4586   if (TREE_VISITED (*tp))
4587     *walk_subtrees = 0;
4588
4589   /* Don't mark a dummy type as visited because we want to mark its sizes
4590      and fields once it's filled in.  */
4591   else if (!TYPE_IS_DUMMY_P (*tp))
4592     TREE_VISITED (*tp) = 1;
4593
4594   if (TYPE_P (*tp))
4595     TYPE_SIZES_GIMPLIFIED (*tp) = 1;
4596
4597   return NULL_TREE;
4598 }
4599
4600 /* Utility function to unshare expressions wrapped up in a SAVE_EXPR.  */
4601
4602 static tree
4603 unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
4604                    void *data ATTRIBUTE_UNUSED)
4605 {
4606   tree t = *tp;
4607
4608   if (TREE_CODE (t) == SAVE_EXPR)
4609     TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0));
4610
4611   return NULL_TREE;
4612 }
4613
4614 /* Add GNU_CLEANUP, a cleanup action, to the current code group.  */
4615
4616 static void
4617 add_cleanup (tree gnu_cleanup)
4618 {
4619   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
4620 }
4621
4622 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
4623
4624 void
4625 set_block_for_group (tree gnu_block)
4626 {
4627   gcc_assert (!current_stmt_group->block);
4628   current_stmt_group->block = gnu_block;
4629 }
4630
4631 /* Return code corresponding to the current code group.  It is normally
4632    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
4633    BLOCK or cleanups were set.  */
4634
4635 static tree
4636 end_stmt_group ()
4637 {
4638   struct stmt_group *group = current_stmt_group;
4639   tree gnu_retval = group->stmt_list;
4640
4641   /* If this is a null list, allocate a new STATEMENT_LIST.  Then, if there
4642      are cleanups, make a TRY_FINALLY_EXPR.  Last, if there is a BLOCK,
4643      make a BIND_EXPR.  Note that we nest in that because the cleanup may
4644      reference variables in the block.  */
4645   if (gnu_retval == NULL_TREE)
4646     gnu_retval = alloc_stmt_list ();
4647
4648   if (group->cleanups)
4649     gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
4650                          group->cleanups);
4651
4652   if (current_stmt_group->block)
4653     gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
4654                          gnu_retval, group->block);
4655
4656   /* Remove this group from the stack and add it to the free list.  */
4657   current_stmt_group = group->previous;
4658   group->previous = stmt_group_free_list;
4659   stmt_group_free_list = group;
4660
4661   return gnu_retval;
4662 }
4663
4664 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
4665    statements.*/
4666
4667 static void
4668 add_stmt_list (List_Id gnat_list)
4669 {
4670   Node_Id gnat_node;
4671
4672   if (Present (gnat_list))
4673     for (gnat_node = First (gnat_list); Present (gnat_node);
4674          gnat_node = Next (gnat_node))
4675       add_stmt (gnat_to_gnu (gnat_node));
4676 }
4677
4678 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
4679    If BINDING_P is true, push and pop a binding level around the list.  */
4680
4681 static tree
4682 build_stmt_group (List_Id gnat_list, bool binding_p)
4683 {
4684   start_stmt_group ();
4685   if (binding_p)
4686     gnat_pushlevel ();
4687
4688   add_stmt_list (gnat_list);
4689   if (binding_p)
4690     gnat_poplevel ();
4691
4692   return end_stmt_group ();
4693 }
4694 \f
4695 /* Push and pop routines for stacks.  We keep a free list around so we
4696    don't waste tree nodes.  */
4697
4698 static void
4699 push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value)
4700 {
4701   tree gnu_node = gnu_stack_free_list;
4702
4703   if (gnu_node)
4704     {
4705       gnu_stack_free_list = TREE_CHAIN (gnu_node);
4706       TREE_CHAIN (gnu_node) = *gnu_stack_ptr;
4707       TREE_PURPOSE (gnu_node) = gnu_purpose;
4708       TREE_VALUE (gnu_node) = gnu_value;
4709     }
4710   else
4711     gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr);
4712
4713   *gnu_stack_ptr = gnu_node;
4714 }
4715
4716 static void
4717 pop_stack (tree *gnu_stack_ptr)
4718 {
4719   tree gnu_node = *gnu_stack_ptr;
4720
4721   *gnu_stack_ptr = TREE_CHAIN (gnu_node);
4722   TREE_CHAIN (gnu_node) = gnu_stack_free_list;
4723   gnu_stack_free_list = gnu_node;
4724 }
4725 \f
4726 /* GNU_STMT is a statement.  We generate code for that statement.  */
4727
4728 void
4729 gnat_expand_stmt (tree gnu_stmt)
4730 {
4731 #if 0
4732   tree gnu_elmt, gnu_elmt_2;
4733 #endif
4734
4735   switch (TREE_CODE (gnu_stmt))
4736     {
4737 #if 0
4738     case USE_STMT:
4739       /* First write a volatile ASM_INPUT to prevent anything from being
4740          moved.  */
4741       gnu_elmt = gen_rtx_ASM_INPUT (VOIDmode, "");
4742       MEM_VOLATILE_P (gnu_elmt) = 1;
4743       emit_insn (gnu_elmt);
4744
4745       gnu_elmt = expand_expr (TREE_OPERAND (gnu_stmt, 0), NULL_RTX, VOIDmode,
4746                             modifier);
4747       emit_insn (gen_rtx_USE (VOIDmode, ));
4748       return target;
4749 #endif
4750
4751     default:
4752       gcc_unreachable ();
4753     }
4754 }
4755 \f
4756 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
4757
4758 int
4759 gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED)
4760 {
4761   tree expr = *expr_p;
4762   tree op;
4763
4764   if (IS_ADA_STMT (expr))
4765     return gnat_gimplify_stmt (expr_p);
4766
4767   switch (TREE_CODE (expr))
4768     {
4769     case NULL_EXPR:
4770       /* If this is for a scalar, just make a VAR_DECL for it.  If for
4771          an aggregate, get a null pointer of the appropriate type and
4772          dereference it.  */
4773       if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
4774         *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
4775                           convert (build_pointer_type (TREE_TYPE (expr)),
4776                                    integer_zero_node));
4777       else
4778         {
4779           *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
4780           TREE_NO_WARNING (*expr_p) = 1;
4781         }
4782
4783       append_to_statement_list (TREE_OPERAND (expr, 0), pre_p);
4784       return GS_OK;
4785
4786     case UNCONSTRAINED_ARRAY_REF:
4787       /* We should only do this if we are just elaborating for side-effects,
4788          but we can't know that yet.  */
4789       *expr_p = TREE_OPERAND (*expr_p, 0);
4790       return GS_OK;
4791
4792     case ADDR_EXPR:
4793       op = TREE_OPERAND (expr, 0);
4794
4795       /* If we're taking the address of a constant CONSTRUCTOR, force it to
4796          be put into static memory.  We know it's going to be readonly given
4797          the semantics we have and it's required to be static memory in
4798          the case when the reference is in an elaboration procedure.   */
4799       if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
4800         {
4801           tree new_var = create_tmp_var (TREE_TYPE (op), "C");
4802
4803           TREE_READONLY (new_var) = 1;
4804           TREE_STATIC (new_var) = 1;
4805           TREE_ADDRESSABLE (new_var) = 1;
4806           DECL_INITIAL (new_var) = op;
4807
4808           TREE_OPERAND (expr, 0) = new_var;
4809           recompute_tree_invariant_for_addr_expr (expr);
4810           return GS_ALL_DONE;
4811         }
4812
4813       /* If we are taking the address of a SAVE_EXPR, we are typically
4814          processing a misaligned argument to be passed by reference in a
4815          procedure call.  We just mark the operand as addressable + not
4816          readonly here and let the common gimplifier code perform the
4817          temporary creation, initialization, and "instantiation" in place of
4818          the SAVE_EXPR in further operands, in particular in the copy back
4819          code inserted after the call.  */
4820       else if (TREE_CODE (op) == SAVE_EXPR)
4821         {
4822           TREE_ADDRESSABLE (op) = 1;
4823           TREE_READONLY (op) = 0;
4824         }
4825
4826       /* Otherwise, if we are taking the address of something that is neither
4827          reference, declaration, or constant, make a variable for the operand
4828          here and then take its address.  If we don't do it this way, we may
4829          confuse the gimplifier because it needs to know the variable is
4830          addressable at this point.  This duplicates code in
4831          internal_get_tmp_var, which is unfortunate.  */
4832       else if (TREE_CODE_CLASS (TREE_CODE (op)) != tcc_reference
4833                && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_declaration
4834                && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_constant)
4835         {
4836           tree new_var = create_tmp_var (TREE_TYPE (op), "A");
4837           tree mod = build2 (GIMPLE_MODIFY_STMT, TREE_TYPE (op), new_var, op);
4838
4839           TREE_ADDRESSABLE (new_var) = 1;
4840
4841           if (EXPR_HAS_LOCATION (op))
4842             SET_EXPR_LOCUS (mod, EXPR_LOCUS (op));
4843
4844           gimplify_and_add (mod, pre_p);
4845           TREE_OPERAND (expr, 0) = new_var;
4846           recompute_tree_invariant_for_addr_expr (expr);
4847           return GS_ALL_DONE;
4848         }
4849
4850       return GS_UNHANDLED;
4851
4852     case COMPONENT_REF:
4853       /* We have a kludge here.  If the FIELD_DECL is from a fat pointer and is
4854          from an early dummy type, replace it with the proper FIELD_DECL.  */
4855       if (TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (*expr_p, 0)))
4856           && DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1)))
4857         {
4858           TREE_OPERAND (*expr_p, 1)
4859             = DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1));
4860           return GS_OK;
4861         }
4862
4863       /* ... fall through ... */
4864
4865     default:
4866       return GS_UNHANDLED;
4867     }
4868 }
4869
4870 /* Generate GIMPLE in place for the statement at *STMT_P.  */
4871
4872 static enum gimplify_status
4873 gnat_gimplify_stmt (tree *stmt_p)
4874 {
4875   tree stmt = *stmt_p;
4876
4877   switch (TREE_CODE (stmt))
4878     {
4879     case STMT_STMT:
4880       *stmt_p = STMT_STMT_STMT (stmt);
4881       return GS_OK;
4882
4883     case USE_STMT:
4884       *stmt_p = NULL_TREE;
4885       return GS_ALL_DONE;
4886
4887     case LOOP_STMT:
4888       {
4889         tree gnu_start_label = create_artificial_label ();
4890         tree gnu_end_label = LOOP_STMT_LABEL (stmt);
4891
4892         /* Set to emit the statements of the loop.  */
4893         *stmt_p = NULL_TREE;
4894
4895         /* We first emit the start label and then a conditional jump to
4896            the end label if there's a top condition, then the body of the
4897            loop, then a conditional branch to the end label, then the update,
4898            if any, and finally a jump to the start label and the definition
4899            of the end label.  */
4900         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
4901                                           gnu_start_label),
4902                                   stmt_p);
4903
4904         if (LOOP_STMT_TOP_COND (stmt))
4905           append_to_statement_list (build3 (COND_EXPR, void_type_node,
4906                                             LOOP_STMT_TOP_COND (stmt),
4907                                             alloc_stmt_list (),
4908                                             build1 (GOTO_EXPR,
4909                                                     void_type_node,
4910                                                     gnu_end_label)),
4911                                     stmt_p);
4912
4913         append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
4914
4915         if (LOOP_STMT_BOT_COND (stmt))
4916           append_to_statement_list (build3 (COND_EXPR, void_type_node,
4917                                             LOOP_STMT_BOT_COND (stmt),
4918                                             alloc_stmt_list (),
4919                                             build1 (GOTO_EXPR,
4920                                                     void_type_node,
4921                                                     gnu_end_label)),
4922                                     stmt_p);
4923
4924         if (LOOP_STMT_UPDATE (stmt))
4925           append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p);
4926
4927         append_to_statement_list (build1 (GOTO_EXPR, void_type_node,
4928                                           gnu_start_label),
4929                                   stmt_p);
4930         append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
4931                                           gnu_end_label),
4932                                   stmt_p);
4933         return GS_OK;
4934       }
4935
4936     case EXIT_STMT:
4937       /* Build a statement to jump to the corresponding end label, then
4938          see if it needs to be conditional.  */
4939       *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
4940       if (EXIT_STMT_COND (stmt))
4941         *stmt_p = build3 (COND_EXPR, void_type_node,
4942                           EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
4943       return GS_OK;
4944
4945     default:
4946       gcc_unreachable ();
4947     }
4948 }
4949 \f
4950 /* Force references to each of the entities in packages withed by GNAT_NODE.
4951    Operate recursively but check that we aren't elaborating something more
4952    than once.
4953
4954    This routine is exclusively called in type_annotate mode, to compute DDA
4955    information for types in withed units, for ASIS use.  */
4956
4957 static void
4958 elaborate_all_entities (Node_Id gnat_node)
4959 {
4960   Entity_Id gnat_with_clause, gnat_entity;
4961
4962   /* Process each unit only once.  As we trace the context of all relevant
4963      units transitively, including generic bodies, we may encounter the
4964      same generic unit repeatedly.  */
4965   if (!present_gnu_tree (gnat_node))
4966      save_gnu_tree (gnat_node, integer_zero_node, true);
4967
4968   /* Save entities in all context units.  A body may have an implicit_with
4969      on its own spec, if the context includes a child unit, so don't save
4970      the spec twice.  */
4971   for (gnat_with_clause = First (Context_Items (gnat_node));
4972        Present (gnat_with_clause);
4973        gnat_with_clause = Next (gnat_with_clause))
4974     if (Nkind (gnat_with_clause) == N_With_Clause
4975         && !present_gnu_tree (Library_Unit (gnat_with_clause))
4976         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
4977       {
4978         elaborate_all_entities (Library_Unit (gnat_with_clause));
4979
4980         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
4981           {
4982             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
4983                  Present (gnat_entity);
4984                  gnat_entity = Next_Entity (gnat_entity))
4985               if (Is_Public (gnat_entity)
4986                   && Convention (gnat_entity) != Convention_Intrinsic
4987                   && Ekind (gnat_entity) != E_Package
4988                   && Ekind (gnat_entity) != E_Package_Body
4989                   && Ekind (gnat_entity) != E_Operator
4990                   && !(IN (Ekind (gnat_entity), Type_Kind)
4991                        && !Is_Frozen (gnat_entity))
4992                   && !((Ekind (gnat_entity) == E_Procedure
4993                         || Ekind (gnat_entity) == E_Function)
4994                        && Is_Intrinsic_Subprogram (gnat_entity))
4995                   && !IN (Ekind (gnat_entity), Named_Kind)
4996                   && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
4997                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4998           }
4999         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
5000           {
5001             Node_Id gnat_body
5002               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
5003
5004             /* Retrieve compilation unit node of generic body.  */
5005             while (Present (gnat_body)
5006                    && Nkind (gnat_body) != N_Compilation_Unit)
5007               gnat_body = Parent (gnat_body);
5008
5009             /* If body is available, elaborate its context.  */
5010             if (Present (gnat_body))
5011               elaborate_all_entities (gnat_body);
5012           }
5013       }
5014
5015   if (Nkind (Unit (gnat_node)) == N_Package_Body)
5016     elaborate_all_entities (Library_Unit (gnat_node));
5017 }
5018 \f
5019 /* Do the processing of N_Freeze_Entity, GNAT_NODE.  */
5020
5021 static void
5022 process_freeze_entity (Node_Id gnat_node)
5023 {
5024   Entity_Id gnat_entity = Entity (gnat_node);
5025   tree gnu_old;
5026   tree gnu_new;
5027   tree gnu_init
5028     = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
5029        && present_gnu_tree (Declaration_Node (gnat_entity)))
5030       ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
5031
5032   /* If this is a package, need to generate code for the package.  */
5033   if (Ekind (gnat_entity) == E_Package)
5034     {
5035       insert_code_for
5036         (Parent (Corresponding_Body
5037                  (Parent (Declaration_Node (gnat_entity)))));
5038       return;
5039     }
5040
5041   /* Check for old definition after the above call.  This Freeze_Node
5042      might be for one its Itypes.  */
5043   gnu_old
5044     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
5045
5046   /* If this entity has an Address representation clause, GNU_OLD is the
5047      address, so discard it here.  */
5048   if (Present (Address_Clause (gnat_entity)))
5049     gnu_old = 0;
5050
5051   /* Don't do anything for class-wide types they are always
5052      transformed into their root type.  */
5053   if (Ekind (gnat_entity) == E_Class_Wide_Type
5054       || (Ekind (gnat_entity) == E_Class_Wide_Subtype
5055           && Present (Equivalent_Type (gnat_entity))))
5056     return;
5057
5058   /* Don't do anything for subprograms that may have been elaborated before
5059      their freeze nodes.  This can happen, for example because of an inner call
5060      in an instance body, or a previous compilation of a spec for inlining
5061      purposes.  */
5062   if  ((gnu_old
5063         && TREE_CODE (gnu_old) == FUNCTION_DECL
5064         && (Ekind (gnat_entity) == E_Function
5065           || Ekind (gnat_entity) == E_Procedure))
5066     || (gnu_old
5067         && (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
5068         && Ekind (gnat_entity) == E_Subprogram_Type)))
5069     return;
5070
5071   /* If we have a non-dummy type old tree, we have nothing to do, except
5072      aborting if this is the public view of a private type whose full view was
5073      not delayed, as this node was never delayed as it should have been.  We
5074      let this happen for concurrent types and their Corresponding_Record_Type,
5075      however, because each might legitimately be elaborated before it's own
5076      freeze node, e.g. while processing the other.  */
5077   if (gnu_old
5078       && !(TREE_CODE (gnu_old) == TYPE_DECL
5079            && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
5080     {
5081       gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5082                    && Present (Full_View (gnat_entity))
5083                    && No (Freeze_Node (Full_View (gnat_entity))))
5084                   || Is_Concurrent_Type (gnat_entity)
5085                   || (IN (Ekind (gnat_entity), Record_Kind)
5086                       && Is_Concurrent_Record_Type (gnat_entity)));
5087       return;
5088     }
5089
5090   /* Reset the saved tree, if any, and elaborate the object or type for real.
5091      If there is a full declaration, elaborate it and copy the type to
5092      GNAT_ENTITY.  Likewise if this is the record subtype corresponding to
5093      a class wide type or subtype.  */
5094   if (gnu_old)
5095     {
5096       save_gnu_tree (gnat_entity, NULL_TREE, false);
5097       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5098           && Present (Full_View (gnat_entity))
5099           && present_gnu_tree (Full_View (gnat_entity)))
5100         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
5101       if (Present (Class_Wide_Type (gnat_entity))
5102           && Class_Wide_Type (gnat_entity) != gnat_entity)
5103         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
5104     }
5105
5106   if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5107       && Present (Full_View (gnat_entity)))
5108     {
5109       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
5110
5111       /* Propagate back-annotations from full view to partial view.  */
5112       if (Unknown_Alignment (gnat_entity))
5113         Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
5114
5115       if (Unknown_Esize (gnat_entity))
5116         Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
5117
5118       if (Unknown_RM_Size (gnat_entity))
5119         Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
5120
5121       /* The above call may have defined this entity (the simplest example
5122          of this is when we have a private enumeral type since the bounds
5123          will have the public view.  */
5124       if (!present_gnu_tree (gnat_entity))
5125         save_gnu_tree (gnat_entity, gnu_new, false);
5126       if (Present (Class_Wide_Type (gnat_entity))
5127           && Class_Wide_Type (gnat_entity) != gnat_entity)
5128         save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
5129     }
5130   else
5131     gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
5132
5133   /* If we've made any pointers to the old version of this type, we
5134      have to update them.  */
5135   if (gnu_old)
5136     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
5137                        TREE_TYPE (gnu_new));
5138 }
5139 \f
5140 /* Process the list of inlined subprograms of GNAT_NODE, which is an
5141    N_Compilation_Unit.  */
5142
5143 static void
5144 process_inlined_subprograms (Node_Id gnat_node)
5145 {
5146   Entity_Id gnat_entity;
5147   Node_Id gnat_body;
5148
5149   /* If we can inline, generate RTL for all the inlined subprograms.
5150      Define the entity first so we set DECL_EXTERNAL.  */
5151   if (optimize > 0 && !flag_really_no_inline)
5152     for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5153          Present (gnat_entity);
5154          gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5155       {
5156         gnat_body = Parent (Declaration_Node (gnat_entity));
5157
5158         if (Nkind (gnat_body) != N_Subprogram_Body)
5159           {
5160             /* ??? This really should always be Present.  */
5161             if (No (Corresponding_Body (gnat_body)))
5162               continue;
5163
5164             gnat_body
5165               = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5166           }
5167
5168         if (Present (gnat_body))
5169           {
5170             gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5171             add_stmt (gnat_to_gnu (gnat_body));
5172           }
5173       }
5174 }
5175 \f
5176 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
5177    We make two passes, one to elaborate anything other than bodies (but
5178    we declare a function if there was no spec).  The second pass
5179    elaborates the bodies.
5180
5181    GNAT_END_LIST gives the element in the list past the end.  Normally,
5182    this is Empty, but can be First_Real_Statement for a
5183    Handled_Sequence_Of_Statements.
5184
5185    We make a complete pass through both lists if PASS1P is true, then make
5186    the second pass over both lists if PASS2P is true.  The lists usually
5187    correspond to the public and private parts of a package.  */
5188
5189 static void
5190 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
5191                Node_Id gnat_end_list, bool pass1p, bool pass2p)
5192 {
5193   List_Id gnat_decl_array[2];
5194   Node_Id gnat_decl;
5195   int i;
5196
5197   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
5198
5199   if (pass1p)
5200     for (i = 0; i <= 1; i++)
5201       if (Present (gnat_decl_array[i]))
5202         for (gnat_decl = First (gnat_decl_array[i]);
5203              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
5204           {
5205             /* For package specs, we recurse inside the declarations,
5206                thus taking the two pass approach inside the boundary.  */
5207             if (Nkind (gnat_decl) == N_Package_Declaration
5208                 && (Nkind (Specification (gnat_decl)
5209                            == N_Package_Specification)))
5210               process_decls (Visible_Declarations (Specification (gnat_decl)),
5211                              Private_Declarations (Specification (gnat_decl)),
5212                              Empty, true, false);
5213
5214             /* Similarly for any declarations in the actions of a
5215                freeze node.  */
5216             else if (Nkind (gnat_decl) == N_Freeze_Entity)
5217               {
5218                 process_freeze_entity (gnat_decl);
5219                 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
5220               }
5221
5222             /* Package bodies with freeze nodes get their elaboration deferred
5223                until the freeze node, but the code must be placed in the right
5224                place, so record the code position now.  */
5225             else if (Nkind (gnat_decl) == N_Package_Body
5226                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
5227               record_code_position (gnat_decl);
5228
5229             else if (Nkind (gnat_decl) == N_Package_Body_Stub
5230                      && Present (Library_Unit (gnat_decl))
5231                      && Present (Freeze_Node
5232                                  (Corresponding_Spec
5233                                   (Proper_Body (Unit
5234                                                 (Library_Unit (gnat_decl)))))))
5235               record_code_position
5236                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
5237
5238             /* We defer most subprogram bodies to the second pass.  */
5239             else if (Nkind (gnat_decl) == N_Subprogram_Body)
5240               {
5241                 if (Acts_As_Spec (gnat_decl))
5242                   {
5243                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
5244
5245                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
5246                         && Ekind (gnat_subprog_id) != E_Generic_Function)
5247                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
5248                   }
5249               }
5250             /* For bodies and stubs that act as their own specs, the entity
5251                itself must be elaborated in the first pass, because it may
5252                be used in other declarations. */
5253             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
5254               {
5255                   Node_Id gnat_subprog_id =
5256                      Defining_Entity (Specification (gnat_decl));
5257
5258                     if (Ekind (gnat_subprog_id) != E_Subprogram_Body
5259                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
5260                         && Ekind (gnat_subprog_id) != E_Generic_Function)
5261                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
5262                }
5263
5264             /* Concurrent stubs stand for the corresponding subprogram bodies,
5265                which are deferred like other bodies.  */
5266             else if (Nkind (gnat_decl) == N_Task_Body_Stub
5267                      || Nkind (gnat_decl) == N_Protected_Body_Stub)
5268               ;
5269             else
5270               add_stmt (gnat_to_gnu (gnat_decl));
5271           }
5272
5273   /* Here we elaborate everything we deferred above except for package bodies,
5274      which are elaborated at their freeze nodes.  Note that we must also
5275      go inside things (package specs and freeze nodes) the first pass did.  */
5276   if (pass2p)
5277     for (i = 0; i <= 1; i++)
5278       if (Present (gnat_decl_array[i]))
5279         for (gnat_decl = First (gnat_decl_array[i]);
5280              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
5281           {
5282             if (Nkind (gnat_decl) == N_Subprogram_Body
5283                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
5284                 || Nkind (gnat_decl) == N_Task_Body_Stub
5285                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
5286               add_stmt (gnat_to_gnu (gnat_decl));
5287
5288             else if (Nkind (gnat_decl) == N_Package_Declaration
5289                      && (Nkind (Specification (gnat_decl)
5290                                 == N_Package_Specification)))
5291               process_decls (Visible_Declarations (Specification (gnat_decl)),
5292                              Private_Declarations (Specification (gnat_decl)),
5293                              Empty, false, true);
5294
5295             else if (Nkind (gnat_decl) == N_Freeze_Entity)
5296               process_decls (Actions (gnat_decl), Empty, Empty, false, true);
5297           }
5298 }
5299 \f
5300 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
5301    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
5302    which we have to check. */
5303
5304 static tree
5305 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
5306 {
5307   tree gnu_range_type = get_unpadded_type (gnat_range_type);
5308   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
5309   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
5310   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
5311
5312   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
5313      we can't do anything since we might be truncating the bounds.  No
5314      check is needed in this case.  */
5315   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
5316       && (TYPE_PRECISION (gnu_compare_type)
5317           < TYPE_PRECISION (get_base_type (gnu_range_type))))
5318     return gnu_expr;
5319
5320   /* Checked expressions must be evaluated only once. */
5321   gnu_expr = protect_multiple_eval (gnu_expr);
5322
5323   /* There's no good type to use here, so we might as well use
5324      integer_type_node. Note that the form of the check is
5325         (not (expr >= lo)) or (not (expr <= hi))
5326       the reason for this slightly convoluted form is that NaN's
5327       are not considered to be in range in the float case. */
5328   return emit_check
5329     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5330                       invert_truthvalue
5331                       (build_binary_op (GE_EXPR, integer_type_node,
5332                                        convert (gnu_compare_type, gnu_expr),
5333                                        convert (gnu_compare_type, gnu_low))),
5334                       invert_truthvalue
5335                       (build_binary_op (LE_EXPR, integer_type_node,
5336                                         convert (gnu_compare_type, gnu_expr),
5337                                         convert (gnu_compare_type,
5338                                                  gnu_high)))),
5339      gnu_expr, CE_Range_Check_Failed);
5340 }
5341 \f
5342 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
5343    which we are about to index, GNU_EXPR is the index expression to be
5344    checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
5345    against which GNU_EXPR has to be checked. Note that for index
5346    checking we cannot use the emit_range_check function (although very
5347    similar code needs to be generated in both cases) since for index
5348    checking the array type against which we are checking the indeces
5349    may be unconstrained and consequently we need to retrieve the
5350    actual index bounds from the array object itself
5351    (GNU_ARRAY_OBJECT). The place where we need to do that is in
5352    subprograms having unconstrained array formal parameters */
5353
5354 static tree
5355 emit_index_check (tree gnu_array_object,
5356                   tree gnu_expr,
5357                   tree gnu_low,
5358                   tree gnu_high)
5359 {
5360   tree gnu_expr_check;
5361
5362   /* Checked expressions must be evaluated only once. */
5363   gnu_expr = protect_multiple_eval (gnu_expr);
5364
5365   /* Must do this computation in the base type in case the expression's
5366      type is an unsigned subtypes.  */
5367   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
5368
5369   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
5370      the object we are handling. */
5371   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
5372   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
5373
5374   /* There's no good type to use here, so we might as well use
5375      integer_type_node.   */
5376   return emit_check
5377     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5378                       build_binary_op (LT_EXPR, integer_type_node,
5379                                        gnu_expr_check,
5380                                        convert (TREE_TYPE (gnu_expr_check),
5381                                                 gnu_low)),
5382                       build_binary_op (GT_EXPR, integer_type_node,
5383                                        gnu_expr_check,
5384                                        convert (TREE_TYPE (gnu_expr_check),
5385                                                 gnu_high))),
5386      gnu_expr, CE_Index_Check_Failed);
5387 }
5388 \f
5389 /* GNU_COND contains the condition corresponding to an access, discriminant or
5390    range check of value GNU_EXPR.  Build a COND_EXPR that returns GNU_EXPR if
5391    GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
5392    REASON is the code that says why the exception was raised.  */
5393
5394 static tree
5395 emit_check (tree gnu_cond, tree gnu_expr, int reason)
5396 {
5397   tree gnu_call;
5398   tree gnu_result;
5399
5400   gnu_call = build_call_raise (reason, Empty);
5401
5402   /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
5403      in front of the comparison in case it ends up being a SAVE_EXPR.  Put the
5404      whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
5405      out.  */
5406   gnu_result = fold (build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
5407                              build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
5408                                      gnu_call, gnu_expr),
5409                              gnu_expr));
5410
5411   /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
5412      protect it.  Otherwise, show GNU_RESULT has no side effects: we
5413      don't need to evaluate it just for the check.  */
5414   if (TREE_SIDE_EFFECTS (gnu_expr))
5415     gnu_result
5416       = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
5417   else
5418     TREE_SIDE_EFFECTS (gnu_result) = 0;
5419
5420   /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
5421      we will repeatedly do the test.  It would be nice if GCC was able
5422      to optimize this and only do it once.  */
5423   return save_expr (gnu_result);
5424 }
5425 \f
5426 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
5427    overflow checks if OVERFLOW_P is nonzero and range checks if
5428    RANGE_P is nonzero.  GNAT_TYPE is known to be an integral type.
5429    If TRUNCATE_P is nonzero, do a float to integer conversion with
5430    truncation; otherwise round.  */
5431
5432 static tree
5433 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
5434                     bool rangep, bool truncatep)
5435 {
5436   tree gnu_type = get_unpadded_type (gnat_type);
5437   tree gnu_in_type = TREE_TYPE (gnu_expr);
5438   tree gnu_in_basetype = get_base_type (gnu_in_type);
5439   tree gnu_base_type = get_base_type (gnu_type);
5440   tree gnu_result = gnu_expr;
5441
5442   /* If we are not doing any checks, the output is an integral type, and
5443      the input is not a floating type, just do the conversion.  This
5444      shortcut is required to avoid problems with packed array types
5445      and simplifies code in all cases anyway.   */
5446   if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
5447       && !FLOAT_TYPE_P (gnu_in_type))
5448     return convert (gnu_type, gnu_expr);
5449
5450   /* First convert the expression to its base type.  This
5451      will never generate code, but makes the tests below much simpler.
5452      But don't do this if converting from an integer type to an unconstrained
5453      array type since then we need to get the bounds from the original
5454      (unpacked) type.  */
5455   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
5456     gnu_result = convert (gnu_in_basetype, gnu_result);
5457
5458   /* If overflow checks are requested,  we need to be sure the result will
5459      fit in the output base type.  But don't do this if the input
5460      is integer and the output floating-point.  */
5461   if (overflowp
5462       && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
5463     {
5464       /* Ensure GNU_EXPR only gets evaluated once.  */
5465       tree gnu_input = protect_multiple_eval (gnu_result);
5466       tree gnu_cond = integer_zero_node;
5467       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
5468       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
5469       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
5470       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
5471
5472       /* Convert the lower bounds to signed types, so we're sure we're
5473          comparing them properly.  Likewise, convert the upper bounds
5474          to unsigned types.  */
5475       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
5476         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
5477
5478       if (INTEGRAL_TYPE_P (gnu_in_basetype)
5479           && !TYPE_UNSIGNED (gnu_in_basetype))
5480         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
5481
5482       if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
5483         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
5484
5485       if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
5486         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
5487
5488       /* Check each bound separately and only if the result bound
5489          is tighter than the bound on the input type.  Note that all the
5490          types are base types, so the bounds must be constant. Also,
5491          the comparison is done in the base type of the input, which
5492          always has the proper signedness.  First check for input
5493          integer (which means output integer), output float (which means
5494          both float), or mixed, in which case we always compare.
5495          Note that we have to do the comparison which would *fail* in the
5496          case of an error since if it's an FP comparison and one of the
5497          values is a NaN or Inf, the comparison will fail.  */
5498       if (INTEGRAL_TYPE_P (gnu_in_basetype)
5499           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
5500           : (FLOAT_TYPE_P (gnu_base_type)
5501              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
5502                                  TREE_REAL_CST (gnu_out_lb))
5503              : 1))
5504         gnu_cond
5505           = invert_truthvalue
5506             (build_binary_op (GE_EXPR, integer_type_node,
5507                               gnu_input, convert (gnu_in_basetype,
5508                                                   gnu_out_lb)));
5509
5510       if (INTEGRAL_TYPE_P (gnu_in_basetype)
5511           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
5512           : (FLOAT_TYPE_P (gnu_base_type)
5513              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
5514                                  TREE_REAL_CST (gnu_in_lb))
5515              : 1))
5516         gnu_cond
5517           = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
5518                              invert_truthvalue
5519                              (build_binary_op (LE_EXPR, integer_type_node,
5520                                                gnu_input,
5521                                                convert (gnu_in_basetype,
5522                                                         gnu_out_ub))));
5523
5524       if (!integer_zerop (gnu_cond))
5525         gnu_result = emit_check (gnu_cond, gnu_input,
5526                                  CE_Overflow_Check_Failed);
5527     }
5528
5529   /* Now convert to the result base type.  If this is a non-truncating
5530      float-to-integer conversion, round.  */
5531   if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
5532       && !truncatep)
5533     {
5534       REAL_VALUE_TYPE half_minus_pred_half, pred_half;
5535       tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type;
5536       tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
5537       const struct real_format *fmt;
5538
5539       /* The following calculations depend on proper rounding to even
5540          of each arithmetic operation. In order to prevent excess
5541          precision from spoiling this property, use the widest hardware
5542          floating-point type.
5543
5544          FIXME: For maximum efficiency, this should only be done for machines
5545          and types where intermediates may have extra precision.  */
5546
5547       calc_type = longest_float_type_node;
5548       /* FIXME: Should not have padding in the first place */
5549       if (TREE_CODE (calc_type) == RECORD_TYPE
5550               && TYPE_IS_PADDING_P (calc_type))
5551         calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
5552
5553       /* Compute the exact value calc_type'Pred (0.5) at compile time. */
5554       fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
5555       real_2expN (&half_minus_pred_half, -(fmt->p) - 1);
5556       REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
5557                        half_minus_pred_half);
5558       gnu_pred_half = build_real (calc_type, pred_half);
5559
5560       /* If the input is strictly negative, subtract this value
5561          and otherwise add it from the input. For 0.5, the result
5562          is exactly between 1.0 and the machine number preceding 1.0
5563          (for calc_type). Since the last bit of 1.0 is even, this 0.5
5564          will round to 1.0, while all other number with an absolute
5565          value less than 0.5 round to 0.0. For larger numbers exactly
5566          halfway between integers, rounding will always be correct as
5567          the true mathematical result will be closer to the higher
5568          integer compared to the lower one. So, this constant works
5569          for all floating-point numbers.
5570
5571          The reason to use the same constant with subtract/add instead
5572          of a positive and negative constant is to allow the comparison
5573          to be scheduled in parallel with retrieval of the constant and
5574          conversion of the input to the calc_type (if necessary).
5575       */
5576
5577       gnu_zero = convert (gnu_in_basetype, integer_zero_node);
5578       gnu_saved_result = save_expr (gnu_result);
5579       gnu_conv = convert (calc_type, gnu_saved_result);
5580       gnu_comp = build2 (GE_EXPR, integer_type_node,
5581                         gnu_saved_result, gnu_zero);
5582       gnu_add_pred_half
5583         = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
5584       gnu_subtract_pred_half
5585         = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
5586       gnu_result = build3 (COND_EXPR, calc_type, gnu_comp,
5587                            gnu_add_pred_half, gnu_subtract_pred_half);
5588     }
5589
5590   if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
5591       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
5592       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
5593     gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
5594   else
5595     gnu_result = convert (gnu_base_type, gnu_result);
5596
5597   /* Finally, do the range check if requested.  Note that if the
5598      result type is a modular type, the range check is actually
5599      an overflow check.  */
5600
5601   if (rangep
5602       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
5603           && TYPE_MODULAR_P (gnu_base_type) && overflowp))
5604     gnu_result = emit_range_check (gnu_result, gnat_type);
5605
5606   return convert (gnu_type, gnu_result);
5607 }
5608 \f
5609 /* Return 1 if GNU_EXPR can be directly addressed.  This is the case unless
5610    it is an expression involving computation or if it involves a reference
5611    to a bitfield or to a field not sufficiently aligned for its type.  */
5612
5613 static bool
5614 addressable_p (tree gnu_expr)
5615 {
5616   switch (TREE_CODE (gnu_expr))
5617     {
5618     case VAR_DECL:
5619     case PARM_DECL:
5620     case FUNCTION_DECL:
5621     case RESULT_DECL:
5622       /* All DECLs are addressable: if they are in a register, we can force
5623          them to memory.  */
5624       return true;
5625
5626     case UNCONSTRAINED_ARRAY_REF:
5627     case INDIRECT_REF:
5628     case CONSTRUCTOR:
5629     case NULL_EXPR:
5630     case SAVE_EXPR:
5631       return true;
5632
5633     case COMPONENT_REF:
5634       return (!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
5635               && (!STRICT_ALIGNMENT
5636                   /* If the field was marked as "semantically" addressable
5637                      in create_field_decl, we are guaranteed that it can
5638                      be directly addressed.  */
5639                   || !DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr, 1))
5640                   /* Otherwise it can nevertheless be directly addressed
5641                      if it has been sufficiently aligned in the record.  */
5642                   || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
5643                        >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))
5644               && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5645
5646     case ARRAY_REF:  case ARRAY_RANGE_REF:
5647     case REALPART_EXPR:  case IMAGPART_EXPR:
5648     case NOP_EXPR:
5649       return addressable_p (TREE_OPERAND (gnu_expr, 0));
5650
5651     case CONVERT_EXPR:
5652       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
5653               && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5654
5655     case VIEW_CONVERT_EXPR:
5656       {
5657         /* This is addressable if we can avoid a copy.  */
5658         tree type = TREE_TYPE (gnu_expr);
5659         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
5660
5661         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
5662                   && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
5663                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
5664                  || ((TYPE_MODE (type) == BLKmode
5665                       || TYPE_MODE (inner_type) == BLKmode)
5666                      && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
5667                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
5668                          || TYPE_ALIGN_OK (type)
5669                          || TYPE_ALIGN_OK (inner_type))))
5670                 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5671       }
5672
5673     default:
5674       return false;
5675     }
5676 }
5677 \f
5678 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
5679    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
5680    make a GCC type for GNAT_ENTITY and set up the correspondence.  */
5681
5682 void
5683 process_type (Entity_Id gnat_entity)
5684 {
5685   tree gnu_old
5686     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
5687   tree gnu_new;
5688
5689   /* If we are to delay elaboration of this type, just do any
5690      elaborations needed for expressions within the declaration and
5691      make a dummy type entry for this node and its Full_View (if
5692      any) in case something points to it.  Don't do this if it
5693      has already been done (the only way that can happen is if
5694      the private completion is also delayed).  */
5695   if (Present (Freeze_Node (gnat_entity))
5696       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5697           && Present (Full_View (gnat_entity))
5698           && Freeze_Node (Full_View (gnat_entity))
5699           && !present_gnu_tree (Full_View (gnat_entity))))
5700     {
5701       elaborate_entity (gnat_entity);
5702
5703       if (!gnu_old)
5704         {
5705           tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
5706                                             make_dummy_type (gnat_entity),
5707                                             NULL, false, false, gnat_entity);
5708
5709           save_gnu_tree (gnat_entity, gnu_decl, false);
5710           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5711               && Present (Full_View (gnat_entity)))
5712             save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
5713         }
5714
5715       return;
5716     }
5717
5718   /* If we saved away a dummy type for this node it means that this
5719      made the type that corresponds to the full type of an incomplete
5720      type.  Clear that type for now and then update the type in the
5721      pointers.  */
5722   if (gnu_old)
5723     {
5724       gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
5725                   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
5726
5727       save_gnu_tree (gnat_entity, NULL_TREE, false);
5728     }
5729
5730   /* Now fully elaborate the type.  */
5731   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
5732   gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
5733
5734   /* If we have an old type and we've made pointers to this type,
5735      update those pointers.  */
5736   if (gnu_old)
5737     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
5738                        TREE_TYPE (gnu_new));
5739
5740   /* If this is a record type corresponding to a task or protected type
5741      that is a completion of an incomplete type, perform a similar update
5742      on the type.  */
5743   /* ??? Including protected types here is a guess. */
5744
5745   if (IN (Ekind (gnat_entity), Record_Kind)
5746       && Is_Concurrent_Record_Type (gnat_entity)
5747       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
5748     {
5749       tree gnu_task_old
5750         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
5751
5752       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
5753                      NULL_TREE, false);
5754       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
5755                      gnu_new, false);
5756
5757       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
5758                          TREE_TYPE (gnu_new));
5759     }
5760 }
5761 \f
5762 /* GNAT_ENTITY is the type of the resulting constructors,
5763    GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
5764    and GNU_TYPE is the GCC type of the corresponding record.
5765
5766    Return a CONSTRUCTOR to build the record.  */
5767
5768 static tree
5769 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
5770 {
5771   tree gnu_list, gnu_result;
5772
5773   /* We test for GNU_FIELD being empty in the case where a variant
5774      was the last thing since we don't take things off GNAT_ASSOC in
5775      that case.  We check GNAT_ASSOC in case we have a variant, but it
5776      has no fields.  */
5777
5778   for (gnu_list = NULL_TREE; Present (gnat_assoc);
5779        gnat_assoc = Next (gnat_assoc))
5780     {
5781       Node_Id gnat_field = First (Choices (gnat_assoc));
5782       tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
5783       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
5784
5785       /* The expander is supposed to put a single component selector name
5786          in every record component association */
5787       gcc_assert (No (Next (gnat_field)));
5788
5789       /* Ignore fields that have Corresponding_Discriminants since we'll
5790          be setting that field in the parent.  */
5791       if (Present (Corresponding_Discriminant (Entity (gnat_field)))
5792           && Is_Tagged_Type (Scope (Entity (gnat_field))))
5793         continue;
5794
5795       /* Also ignore discriminants of Unchecked_Unions.  */
5796       else if (Is_Unchecked_Union (gnat_entity)
5797                && Ekind (Entity (gnat_field)) == E_Discriminant)
5798         continue;
5799
5800       /* Before assigning a value in an aggregate make sure range checks
5801          are done if required.  Then convert to the type of the field.  */
5802       if (Do_Range_Check (Expression (gnat_assoc)))
5803         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
5804
5805       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
5806
5807       /* Add the field and expression to the list.  */
5808       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
5809     }
5810
5811   gnu_result = extract_values (gnu_list, gnu_type);
5812
5813 #ifdef ENABLE_CHECKING
5814   {
5815     tree gnu_field;
5816
5817     /* Verify every enty in GNU_LIST was used.  */
5818     for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
5819       gcc_assert (TREE_ADDRESSABLE (gnu_field));
5820   }
5821 #endif
5822
5823   return gnu_result;
5824 }
5825
5826 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
5827    is the first element of an array aggregate. It may itself be an
5828    aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
5829    corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
5830    of the array component. It is needed for range checking. */
5831
5832 static tree
5833 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
5834                     Entity_Id gnat_component_type)
5835 {
5836   tree gnu_expr_list = NULL_TREE;
5837   tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
5838   tree gnu_expr;
5839
5840   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
5841     {
5842       /* If the expression is itself an array aggregate then first build the
5843          innermost constructor if it is part of our array (multi-dimensional
5844          case).  */
5845
5846       if (Nkind (gnat_expr) == N_Aggregate
5847           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
5848           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
5849         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
5850                                        TREE_TYPE (gnu_array_type),
5851                                        gnat_component_type);
5852       else
5853         {
5854           gnu_expr = gnat_to_gnu (gnat_expr);
5855
5856           /* before assigning the element to the array make sure it is
5857              in range */
5858           if (Do_Range_Check (gnat_expr))
5859             gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
5860         }
5861
5862       gnu_expr_list
5863         = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr),
5864                      gnu_expr_list);
5865
5866       gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
5867     }
5868
5869   return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
5870 }
5871 \f
5872 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5873    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
5874    of the associations that are from RECORD_TYPE.  If we see an internal
5875    record, make a recursive call to fill it in as well.  */
5876
5877 static tree
5878 extract_values (tree values, tree record_type)
5879 {
5880   tree result = NULL_TREE;
5881   tree field, tem;
5882
5883   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
5884     {
5885       tree value = 0;
5886
5887       /* _Parent is an internal field, but may have values in the aggregate,
5888          so check for values first.  */
5889       if ((tem = purpose_member (field, values)))
5890         {
5891           value = TREE_VALUE (tem);
5892           TREE_ADDRESSABLE (tem) = 1;
5893         }
5894
5895       else if (DECL_INTERNAL_P (field))
5896         {
5897           value = extract_values (values, TREE_TYPE (field));
5898           if (TREE_CODE (value) == CONSTRUCTOR
5899               && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
5900             value = 0;
5901         }
5902       else
5903         /* If we have a record subtype, the names will match, but not the
5904            actual FIELD_DECLs.  */
5905         for (tem = values; tem; tem = TREE_CHAIN (tem))
5906           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
5907             {
5908               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
5909               TREE_ADDRESSABLE (tem) = 1;
5910             }
5911
5912       if (!value)
5913         continue;
5914
5915       result = tree_cons (field, value, result);
5916     }
5917
5918   return gnat_build_constructor (record_type, nreverse (result));
5919 }
5920 \f
5921 /* EXP is to be treated as an array or record.  Handle the cases when it is
5922    an access object and perform the required dereferences.  */
5923
5924 static tree
5925 maybe_implicit_deref (tree exp)
5926 {
5927   /* If the type is a pointer, dereference it.  */
5928
5929   if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
5930     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
5931
5932   /* If we got a padded type, remove it too.  */
5933   if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
5934       && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
5935     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
5936
5937   return exp;
5938 }
5939 \f
5940 /* Protect EXP from multiple evaluation.  This may make a SAVE_EXPR.  */
5941
5942 tree
5943 protect_multiple_eval (tree exp)
5944 {
5945   tree type = TREE_TYPE (exp);
5946
5947   /* If this has no side effects, we don't need to do anything.  */
5948   if (!TREE_SIDE_EFFECTS (exp))
5949     return exp;
5950
5951   /* If it is a conversion, protect what's inside the conversion.
5952      Similarly, if we're indirectly referencing something, we only
5953      actually need to protect the address since the data itself can't
5954      change in these situations.  */
5955   else if (TREE_CODE (exp) == NON_LVALUE_EXPR
5956            || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR
5957            || TREE_CODE (exp) == VIEW_CONVERT_EXPR
5958            || TREE_CODE (exp) == INDIRECT_REF
5959            || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
5960     return build1 (TREE_CODE (exp), type,
5961                    protect_multiple_eval (TREE_OPERAND (exp, 0)));
5962
5963   /* If EXP is a fat pointer or something that can be placed into a register,
5964      just make a SAVE_EXPR.  */
5965   if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
5966     return save_expr (exp);
5967
5968   /* Otherwise, dereference, protect the address, and re-reference.  */
5969   else
5970     return
5971       build_unary_op (INDIRECT_REF, type,
5972                       save_expr (build_unary_op (ADDR_EXPR,
5973                                                  build_reference_type (type),
5974                                                  exp)));
5975 }
5976 \f
5977 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know how
5978    to handle our new nodes and we take extra arguments:
5979
5980    FORCE says whether to force evaluation of everything,
5981
5982    SUCCESS we set to true unless we walk through something we don't know how
5983    to stabilize, or through something which is not an lvalue and LVALUES_ONLY
5984    is true, in which cases we set to false.  */
5985
5986 tree
5987 maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
5988                            bool *success)
5989 {
5990   tree type = TREE_TYPE (ref);
5991   enum tree_code code = TREE_CODE (ref);
5992   tree result;
5993
5994   /* Assume we'll success unless proven otherwise.  */
5995   *success = true;
5996
5997   switch (code)
5998     {
5999     case VAR_DECL:
6000     case PARM_DECL:
6001     case RESULT_DECL:
6002       /* No action is needed in this case.  */
6003       return ref;
6004
6005     case ADDR_EXPR:
6006       /*  A standalone ADDR_EXPR is never an lvalue, and this one can't
6007           be nested inside an outer INDIRECT_REF, since INDIREC_REF goes
6008           straight to stabilize_1.  */
6009       if (lvalues_only)
6010         goto failure;
6011
6012       /* ... Fallthru ... */
6013
6014     case NOP_EXPR:
6015     case CONVERT_EXPR:
6016     case FLOAT_EXPR:
6017     case FIX_TRUNC_EXPR:
6018     case VIEW_CONVERT_EXPR:
6019       result
6020         = build1 (code, type,
6021                   maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
6022                                              lvalues_only, success));
6023       break;
6024
6025     case INDIRECT_REF:
6026     case UNCONSTRAINED_ARRAY_REF:
6027       result = build1 (code, type,
6028                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
6029                                                    force));
6030       break;
6031
6032     case COMPONENT_REF:
6033      result = build3 (COMPONENT_REF, type,
6034                       maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
6035                                                  lvalues_only, success),
6036                       TREE_OPERAND (ref, 1), NULL_TREE);
6037       break;
6038
6039     case BIT_FIELD_REF:
6040       result = build3 (BIT_FIELD_REF, type,
6041                        maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
6042                                                   lvalues_only, success),
6043                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
6044                                                    force),
6045                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
6046                                                    force));
6047       break;
6048
6049     case ARRAY_REF:
6050     case ARRAY_RANGE_REF:
6051       result = build4 (code, type,
6052                        maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
6053                                                   lvalues_only, success),
6054                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
6055                                                    force),
6056                        NULL_TREE, NULL_TREE);
6057       break;
6058
6059     case COMPOUND_EXPR:
6060       result = build2 (COMPOUND_EXPR, type,
6061                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
6062                                                    force),
6063                        maybe_stabilize_reference (TREE_OPERAND (ref, 1), force,
6064                                                   lvalues_only, success));
6065       break;
6066
6067     case ERROR_MARK:
6068       ref = error_mark_node;
6069
6070       /* ...  Fallthru to failure ... */
6071
6072       /* If arg isn't a kind of lvalue we recognize, make no change.
6073          Caller should recognize the error for an invalid lvalue.  */
6074     default:
6075     failure:
6076       *success = false;
6077       return ref;
6078     }
6079
6080   TREE_READONLY (result) = TREE_READONLY (ref);
6081
6082   /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
6083      expression may not be sustained across some paths, such as the way via
6084      build1 for INDIRECT_REF.  We re-populate those flags here for the general
6085      case, which is consistent with the GCC version of this routine.
6086
6087      Special care should be taken regarding TREE_SIDE_EFFECTS, because some
6088      paths introduce side effects where there was none initially (e.g. calls
6089      to save_expr), and we also want to keep track of that.  */
6090
6091   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
6092   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
6093
6094   return result;
6095 }
6096
6097 /* Wrapper around maybe_stabilize_reference, for common uses without
6098    lvalue restrictions and without need to examine the success
6099    indication.  */
6100
6101 tree
6102 gnat_stabilize_reference (tree ref, bool force)
6103 {
6104   bool stabilized;
6105   return maybe_stabilize_reference (ref, force, false, &stabilized);
6106 }
6107
6108 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
6109    arg to force a SAVE_EXPR for everything.  */
6110
6111 static tree
6112 gnat_stabilize_reference_1 (tree e, bool force)
6113 {
6114   enum tree_code code = TREE_CODE (e);
6115   tree type = TREE_TYPE (e);
6116   tree result;
6117
6118   /* We cannot ignore const expressions because it might be a reference
6119      to a const array but whose index contains side-effects.  But we can
6120      ignore things that are actual constant or that already have been
6121      handled by this function.  */
6122
6123   if (TREE_CONSTANT (e) || code == SAVE_EXPR)
6124     return e;
6125
6126   switch (TREE_CODE_CLASS (code))
6127     {
6128     case tcc_exceptional:
6129     case tcc_type:
6130     case tcc_declaration:
6131     case tcc_comparison:
6132     case tcc_statement:
6133     case tcc_expression:
6134     case tcc_reference:
6135     case tcc_vl_exp:
6136       /* If this is a COMPONENT_REF of a fat pointer, save the entire
6137          fat pointer.  This may be more efficient, but will also allow
6138          us to more easily find the match for the PLACEHOLDER_EXPR.  */
6139       if (code == COMPONENT_REF
6140           && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
6141         result = build3 (COMPONENT_REF, type,
6142                          gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
6143                                                      force),
6144                          TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
6145       else if (TREE_SIDE_EFFECTS (e) || force)
6146         return save_expr (e);
6147       else
6148         return e;
6149       break;
6150
6151     case tcc_constant:
6152       /* Constants need no processing.  In fact, we should never reach
6153          here.  */
6154       return e;
6155
6156     case tcc_binary:
6157       /* Recursively stabilize each operand.  */
6158       result = build2 (code, type,
6159                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
6160                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
6161                                                    force));
6162       break;
6163
6164     case tcc_unary:
6165       /* Recursively stabilize each operand.  */
6166       result = build1 (code, type,
6167                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
6168                                                    force));
6169       break;
6170
6171     default:
6172       gcc_unreachable ();
6173     }
6174
6175   TREE_READONLY (result) = TREE_READONLY (e);
6176
6177   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
6178   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
6179   return result;
6180 }
6181 \f
6182 extern char *__gnat_to_canonical_file_spec (char *);
6183
6184 /* Convert Sloc into *LOCUS (a location_t).  Return true if this Sloc
6185    corresponds to a source code location and false if it doesn't.  In the
6186    latter case, we don't update *LOCUS.  We also set the Gigi global variable
6187    REF_FILENAME to the reference file name as given by sinput (i.e no
6188    directory).  */
6189
6190 bool
6191 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
6192 {
6193   /* If node not from source code, ignore.  */
6194   if (Sloc < 0)
6195     return false;
6196
6197   /* Use the identifier table to make a hashed, permanent copy of the filename,
6198      since the name table gets reallocated after Gigi returns but before all
6199      the debugging information is output. The __gnat_to_canonical_file_spec
6200      call translates filenames from pragmas Source_Reference that contain host
6201      style syntax not understood by gdb. */
6202   locus->file
6203     = IDENTIFIER_POINTER
6204       (get_identifier
6205        (__gnat_to_canonical_file_spec
6206         (Get_Name_String (Full_Debug_Name (Get_Source_File_Index (Sloc))))));
6207
6208   locus->line = Get_Logical_Line_Number (Sloc);
6209
6210   ref_filename
6211     = IDENTIFIER_POINTER
6212       (get_identifier
6213        (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
6214
6215   return true;
6216 }
6217
6218 /* Similar to annotate_with_locus, but start with the Sloc of GNAT_NODE and
6219    don't do anything if it doesn't correspond to a source location.  */
6220
6221 static void
6222 annotate_with_node (tree node, Node_Id gnat_node)
6223 {
6224   location_t locus;
6225
6226   if (!Sloc_to_locus (Sloc (gnat_node), &locus))
6227     return;
6228
6229   annotate_with_locus (node, locus);
6230 }
6231 \f
6232 /* Post an error message.  MSG is the error message, properly annotated.
6233    NODE is the node at which to post the error and the node to use for the
6234    "&" substitution.  */
6235
6236 void
6237 post_error (const char *msg, Node_Id node)
6238 {
6239   String_Template temp;
6240   Fat_Pointer fp;
6241
6242   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6243   fp.Array = msg, fp.Bounds = &temp;
6244   if (Present (node))
6245     Error_Msg_N (fp, node);
6246 }
6247
6248 /* Similar, but NODE is the node at which to post the error and ENT
6249    is the node to use for the "&" substitution.  */
6250
6251 void
6252 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
6253 {
6254   String_Template temp;
6255   Fat_Pointer fp;
6256
6257   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6258   fp.Array = msg, fp.Bounds = &temp;
6259   if (Present (node))
6260     Error_Msg_NE (fp, node, ent);
6261 }
6262
6263 /* Similar, but NODE is the node at which to post the error, ENT is the node
6264    to use for the "&" substitution, and N is the number to use for the ^.  */
6265
6266 void
6267 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
6268 {
6269   String_Template temp;
6270   Fat_Pointer fp;
6271
6272   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6273   fp.Array = msg, fp.Bounds = &temp;
6274   Error_Msg_Uint_1 = UI_From_Int (n);
6275
6276   if (Present (node))
6277     Error_Msg_NE (fp, node, ent);
6278 }
6279 \f
6280 /* Similar to post_error_ne_num, but T is a GCC tree representing the
6281    number to write.  If the tree represents a constant that fits within
6282    a host integer, the text inside curly brackets in MSG will be output
6283    (presumably including a '^').  Otherwise that text will not be output
6284    and the text inside square brackets will be output instead.  */
6285
6286 void
6287 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
6288 {
6289   char *newmsg = alloca (strlen (msg) + 1);
6290   String_Template temp = {1, 0};
6291   Fat_Pointer fp;
6292   char start_yes, end_yes, start_no, end_no;
6293   const char *p;
6294   char *q;
6295
6296   fp.Array = newmsg, fp.Bounds = &temp;
6297
6298   if (host_integerp (t, 1)
6299 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
6300       &&
6301       compare_tree_int
6302       (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
6303 #endif
6304       )
6305     {
6306       Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
6307       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
6308     }
6309   else
6310     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
6311
6312   for (p = msg, q = newmsg; *p; p++)
6313     {
6314       if (*p == start_yes)
6315         for (p++; *p != end_yes; p++)
6316           *q++ = *p;
6317       else if (*p == start_no)
6318         for (p++; *p != end_no; p++)
6319           ;
6320       else
6321         *q++ = *p;
6322     }
6323
6324   *q = 0;
6325
6326   temp.High_Bound = strlen (newmsg);
6327   if (Present (node))
6328     Error_Msg_NE (fp, node, ent);
6329 }
6330
6331 /* Similar to post_error_ne_tree, except that NUM is a second
6332    integer to write in the message.  */
6333
6334 void
6335 post_error_ne_tree_2 (const char *msg,
6336                       Node_Id node,
6337                       Entity_Id ent,
6338                       tree t,
6339                       int num)
6340 {
6341   Error_Msg_Uint_2 = UI_From_Int (num);
6342   post_error_ne_tree (msg, node, ent, t);
6343 }
6344 \f
6345 /* Initialize the table that maps GNAT codes to GCC codes for simple
6346    binary and unary operations.  */
6347
6348 void
6349 init_code_table (void)
6350 {
6351   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
6352   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
6353
6354   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
6355   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
6356   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
6357   gnu_codes[N_Op_Eq] = EQ_EXPR;
6358   gnu_codes[N_Op_Ne] = NE_EXPR;
6359   gnu_codes[N_Op_Lt] = LT_EXPR;
6360   gnu_codes[N_Op_Le] = LE_EXPR;
6361   gnu_codes[N_Op_Gt] = GT_EXPR;
6362   gnu_codes[N_Op_Ge] = GE_EXPR;
6363   gnu_codes[N_Op_Add] = PLUS_EXPR;
6364   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
6365   gnu_codes[N_Op_Multiply] = MULT_EXPR;
6366   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
6367   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
6368   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
6369   gnu_codes[N_Op_Abs] = ABS_EXPR;
6370   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
6371   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
6372   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
6373   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
6374   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
6375   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
6376 }
6377
6378 #include "gt-ada-trans.h"