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