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