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
 691       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
 692     return gnu_result;
 693
 694   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
 695     {
 696     case Pragma_Inspection_Point:
 697       /* Do nothing at top level: all such variables are already viewable.  */
 698       if (global_bindings_p ())
 699         break;
 700
 701       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
 702            Present (gnat_temp);
 703            gnat_temp = Next (gnat_temp))
 704         {
 705           Node_Id gnat_expr = Expression (gnat_temp);
 706           tree gnu_expr = gnat_to_gnu (gnat_expr);
 707           int use_address;
 708           enum machine_mode mode;
 709           tree asm_constraint = NULL_TREE;
 710 #ifdef ASM_COMMENT_START
 711           char *comment;
 712 #endif
 713
 714           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
 715             gnu_expr = TREE_OPERAND (gnu_expr, 0);
 716
 717           /* Use the value only if it fits into a normal register,
 718              otherwise use the address.  */
 719           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
 720           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
 721                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
 722                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
 723
 724           if (use_address)
 725             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
 726
 727 #ifdef ASM_COMMENT_START
 728           comment = concat (ASM_COMMENT_START,
 729                             " inspection point: ",
 730                             Get_Name_String (Chars (gnat_expr)),
 731                             use_address ? " address" : "",
 732                             " is in %0",
 733                             NULL);
 734           asm_constraint = build_string (strlen (comment), comment);
 735           free (comment);
 736 #endif
 737           gnu_expr = build4 (ASM_EXPR, void_type_node,
 738                              asm_constraint,
 739                              NULL_TREE,
 740                              tree_cons
 741                              (build_tree_list (NULL_TREE,
 742                                                build_string (1, "g")),
 743                               gnu_expr, NULL_TREE),
 744                              NULL_TREE);
 745           ASM_VOLATILE_P (gnu_expr) = 1;
 746           set_expr_location_from_node (gnu_expr, gnat_node);
 747           append_to_statement_list (gnu_expr, &gnu_result);
 748         }
 749       break;
 750
 751     case Pragma_Optimize:
 752       switch (Chars (Expression
 753                      (First (Pragma_Argument_Associations (gnat_node)))))
 754         {
 755         case Name_Time:  case Name_Space:
 756           if (optimize == 0)
 757             post_error ("insufficient -O value?", gnat_node);
 758           break;
 759
 760         case Name_Off:
 761           if (optimize != 0)
 762             post_error ("must specify -O0?", gnat_node);
 763           break;
 764
 765         default:
 766           gcc_unreachable ();
 767         }
 768       break;
 769
 770     case Pragma_Reviewable:
 771       if (write_symbols == NO_DEBUG)
 772         post_error ("must specify -g?", gnat_node);
 773       break;
 774     }
 775
 776   return gnu_result;
 777 }
 778 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
 779    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
 780    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
 781
 782 static tree
 783 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 784 {
 785   tree gnu_result = error_mark_node;
 786   tree gnu_result_type;
 787   tree gnu_expr;
 788   bool prefix_unused = false;
 789   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
 790   tree gnu_type = TREE_TYPE (gnu_prefix);
 791
 792   /* If the input is a NULL_EXPR, make a new one.  */
 793   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
 794     {
 795       *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
 796       return build1 (NULL_EXPR, *gnu_result_type_p,
 797                      TREE_OPERAND (gnu_prefix, 0));
 798     }
 799
 800   switch (attribute)
 801     {
 802     case Attr_Pos:
 803     case Attr_Val:
 804       /* These are just conversions until since representation clauses for
 805          enumerations are handled in the front end.  */
 806       {
 807         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
 808
 809         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
 810         gnu_result_type = get_unpadded_type (Etype (gnat_node));
 811         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
 812                                          checkp, checkp, true);
 813       }
 814       break;
 815
 816     case Attr_Pred:
 817     case Attr_Succ:
 818       /* These just add or subject the constant 1.  Representation clauses for
 819          enumerations are handled in the front-end.  */
 820       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
 821       gnu_result_type = get_unpadded_type (Etype (gnat_node));
 822
 823       if (Do_Range_Check (First (Expressions (gnat_node))))
 824         {
 825           gnu_expr = protect_multiple_eval (gnu_expr);
 826           gnu_expr
 827             = emit_check
 828               (build_binary_op (EQ_EXPR, integer_type_node,
 829                                 gnu_expr,
 830                                 attribute == Attr_Pred
 831                                 ? TYPE_MIN_VALUE (gnu_result_type)
 832                                 : TYPE_MAX_VALUE (gnu_result_type)),
 833                gnu_expr, CE_Range_Check_Failed);
 834         }
 835
 836       gnu_result
 837         = build_binary_op (attribute == Attr_Pred
 838                            ? MINUS_EXPR : PLUS_EXPR,
 839                            gnu_result_type, gnu_expr,
 840                            convert (gnu_result_type, integer_one_node));
 841       break;
 842
 843     case Attr_Address:
 844     case Attr_Unrestricted_Access:
 845       /* Conversions don't change something's address but can cause us to miss
 846          the COMPONENT_REF case below, so strip them off.  */
 847       gnu_prefix = remove_conversions (gnu_prefix,
 848                                        !Must_Be_Byte_Aligned (gnat_node));
 849
 850       /* If we are taking 'Address of an unconstrained object, this is the
 851          pointer to the underlying array.  */
 852       if (attribute == Attr_Address)
 853         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
 854
 855       /* If we are building a static dispatch table, we have to honor
 856          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
 857          with the C++ ABI.  We do it in the non-static case as well,
 858          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
 859       else if (TARGET_VTABLE_USES_DESCRIPTORS
 860                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
 861         {
 862           tree gnu_field, gnu_list = NULL_TREE, t;
 863           /* Descriptors can only be built here for top-level functions.  */
 864           bool build_descriptor = (global_bindings_p () != 0);
 865           int i;
 866
 867           gnu_result_type = get_unpadded_type (Etype (gnat_node));
 868
 869           /* If we're not going to build the descriptor, we have to retrieve
 870              the one which will be built by the linker (or by the compiler
 871              later if a static chain is requested).  */
 872           if (!build_descriptor)
 873             {
 874               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
 875               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
 876                                          gnu_result);
 877               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
 878             }
 879
 880           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
 881                i < TARGET_VTABLE_USES_DESCRIPTORS;
 882                gnu_field = TREE_CHAIN (gnu_field), i++)
 883             {
 884               if (build_descriptor)
 885                 {
 886                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
 887                               build_int_cst (NULL_TREE, i));
 888                   TREE_CONSTANT (t) = 1;
 889                   TREE_INVARIANT (t) = 1;
 890                 }
 891               else
 892                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
 893                             gnu_field, NULL_TREE);
 894
 895               gnu_list = tree_cons (gnu_field, t, gnu_list);
 896             }
 897
 898           gnu_result = gnat_build_constructor (gnu_result_type, gnu_list);
 899           break;
 900         }
 901
 902       /* ... fall through ... */
 903
 904     case Attr_Access:
 905     case Attr_Unchecked_Access:
 906     case Attr_Code_Address:
 907       gnu_result_type = get_unpadded_type (Etype (gnat_node));
 908       gnu_result
 909         = build_unary_op (((attribute == Attr_Address
 910                             || attribute == Attr_Unrestricted_Access)
 911                            && !Must_Be_Byte_Aligned (gnat_node))
 912                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
 913                           gnu_result_type, gnu_prefix);
 914
 915       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
 916          don't try to build a trampoline.  */
 917       if (attribute == Attr_Code_Address)
 918         {
 919           for (gnu_expr = gnu_result;
 920                TREE_CODE (gnu_expr) == NOP_EXPR
 921                || TREE_CODE (gnu_expr) == CONVERT_EXPR;
 922                gnu_expr = TREE_OPERAND (gnu_expr, 0))
 923             TREE_CONSTANT (gnu_expr) = 1;
 924
 925           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
 926             TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
 927         }
 928
 929       /* For other address attributes applied to a nested function,
 930          find an inner ADDR_EXPR and annotate it so that we can issue
 931          a useful warning with -Wtrampolines.  */
 932       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
 933         {
 934           for (gnu_expr = gnu_result;
 935                TREE_CODE (gnu_expr) == NOP_EXPR
 936                || TREE_CODE (gnu_expr) == CONVERT_EXPR;
 937                gnu_expr = TREE_OPERAND (gnu_expr, 0))
 938             ;
 939
 940           if (TREE_CODE (gnu_expr) == ADDR_EXPR
 941               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
 942             {
 943               set_expr_location_from_node (gnu_expr, gnat_node);
 944
 945               /* Check that we're not violating the No_Implicit_Dynamic_Code
 946                  restriction.  Be conservative if we don't know anything
 947                  about the trampoline strategy for the target.  */
 948               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
 949             }
 950         }
 951       break;
 952
 953     case Attr_Pool_Address:
 954       {
 955         tree gnu_obj_type;
 956         tree gnu_ptr = gnu_prefix;
 957
 958         gnu_result_type = get_unpadded_type (Etype (gnat_node));
 959
 960         /* If this is an unconstrained array, we know the object must have been
 961            allocated with the template in front of the object.  So compute the
 962            template address.*/
 963         if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
 964           gnu_ptr
 965             = convert (build_pointer_type
 966                        (TYPE_OBJECT_RECORD_TYPE
 967                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
 968                        gnu_ptr);
 969
 970         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
 971         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
 972             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
 973           {
 974             tree gnu_char_ptr_type = build_pointer_type (char_type_node);
 975             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
 976             tree gnu_byte_offset
 977               = convert (sizetype,
 978                          size_diffop (size_zero_node, gnu_pos));
 979             gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
 980
 981             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
 982             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
 983                                        gnu_ptr, gnu_byte_offset);
 984           }
 985
 986         gnu_result = convert (gnu_result_type, gnu_ptr);
 987       }
 988       break;
 989
 990     case Attr_Size:
 991     case Attr_Object_Size:
 992     case Attr_Value_Size:
 993     case Attr_Max_Size_In_Storage_Elements:
 994       gnu_expr = gnu_prefix;
 995
 996       /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
 997          We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
 998       while (TREE_CODE (gnu_expr) == NOP_EXPR)
 999         gnu_expr = TREE_OPERAND (gnu_expr, 0)
1000           ;
1001
1002       gnu_prefix = remove_conversions (gnu_prefix, true);
1003       prefix_unused = true;
1004       gnu_type = TREE_TYPE (gnu_prefix);
1005
1006       /* Replace an unconstrained array type with the type of the underlying
1007          array.  We can't do this with a call to maybe_unconstrained_array
1008          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1009          use the record type that will be used to allocate the object and its
1010          template.  */
1011       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1012         {
1013           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1014           if (attribute != Attr_Max_Size_In_Storage_Elements)
1015             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1016         }
1017
1018       /* If we're looking for the size of a field, return the field size.
1019          Otherwise, if the prefix is an object, or if 'Object_Size or
1020          'Max_Size_In_Storage_Elements has been specified, the result is the
1021          GCC size of the type. Otherwise, the result is the RM_Size of the
1022          type.  */
1023       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1024         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1025       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1026                || attribute == Attr_Object_Size
1027                || attribute == Attr_Max_Size_In_Storage_Elements)
1028         {
1029           /* If this is a padded type, the GCC size isn't relevant to the
1030              programmer.  Normally, what we want is the RM_Size, which was set
1031              from the specified size, but if it was not set, we want the size
1032              of the relevant field.  Using the MAX of those two produces the
1033              right result in all case.  Don't use the size of the field if it's
1034              a self-referential type, since that's never what's wanted.  */
1035           if (TREE_CODE (gnu_type) == RECORD_TYPE
1036               && TYPE_IS_PADDING_P (gnu_type)
1037               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1038             {
1039               gnu_result = rm_size (gnu_type);
1040               if (!(CONTAINS_PLACEHOLDER_P
1041                     (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
1042                 gnu_result
1043                   = size_binop (MAX_EXPR, gnu_result,
1044                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1045             }
1046           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1047             {
1048               Node_Id gnat_deref = Prefix (gnat_node);
1049               Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
1050               tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1051               if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1052                 && Present (gnat_actual_subtype))
1053                 {
1054                   tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
1055                   gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
1056                                gnu_actual_obj_type, get_identifier ("SIZE"));
1057                 }
1058
1059               gnu_result = TYPE_SIZE (gnu_type);
1060             }
1061           else
1062             gnu_result = TYPE_SIZE (gnu_type);
1063         }
1064       else
1065         gnu_result = rm_size (gnu_type);
1066
1067       gcc_assert (gnu_result);
1068
1069       /* Deal with a self-referential size by returning the maximum size for a
1070          type and by qualifying the size with the object for 'Size of an
1071          object.  */
1072       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1073         {
1074           if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1075             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1076           else
1077             gnu_result = max_size (gnu_result, true);
1078         }
1079
1080       /* If the type contains a template, subtract its size.  */
1081       if (TREE_CODE (gnu_type) == RECORD_TYPE
1082           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1083         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1084                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1085
1086       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1087
1088       /* Always perform division using unsigned arithmetic as the size cannot
1089          be negative, but may be an overflowed positive value. This provides
1090          correct results for sizes up to 512 MB.
1091
1092          ??? Size should be calculated in storage elements directly.  */
1093
1094       if (attribute == Attr_Max_Size_In_Storage_Elements)
1095         gnu_result = convert (sizetype,
1096                               fold_build2 (CEIL_DIV_EXPR, bitsizetype,
1097                                            gnu_result, bitsize_unit_node));
1098       break;
1099
1100     case Attr_Alignment:
1101       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1102           && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1103               == RECORD_TYPE)
1104           && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1105         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1106
1107       gnu_type = TREE_TYPE (gnu_prefix);
1108       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1109       prefix_unused = true;
1110
1111       gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF
1112                               ? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))
1113                               : TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT);
1114       break;
1115
1116     case Attr_First:
1117     case Attr_Last:
1118     case Attr_Range_Length:
1119       prefix_unused = true;
1120
1121       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1122         {
1123           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1124
1125           if (attribute == Attr_First)
1126             gnu_result = TYPE_MIN_VALUE (gnu_type);
1127           else if (attribute == Attr_Last)
1128             gnu_result = TYPE_MAX_VALUE (gnu_type);
1129           else
1130             gnu_result
1131               = build_binary_op
1132                 (MAX_EXPR, get_base_type (gnu_result_type),
1133                  build_binary_op
1134                  (PLUS_EXPR, get_base_type (gnu_result_type),
1135                   build_binary_op (MINUS_EXPR,
1136                                    get_base_type (gnu_result_type),
1137                                    convert (gnu_result_type,
1138                                             TYPE_MAX_VALUE (gnu_type)),
1139                                    convert (gnu_result_type,
1140                                             TYPE_MIN_VALUE (gnu_type))),
1141                   convert (gnu_result_type, integer_one_node)),
1142                  convert (gnu_result_type, integer_zero_node));
1143
1144           break;
1145         }
1146
1147       /* ... fall through ... */
1148
1149     case Attr_Length:
1150       {
1151         int Dimension = (Present (Expressions (gnat_node))
1152                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1153                          : 1), i;
1154         struct parm_attr *pa = NULL;
1155         Entity_Id gnat_param = Empty;
1156
1157         /* Make sure any implicit dereference gets done.  */
1158         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1159         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1160         /* We treat unconstrained array In parameters specially.  */
1161         if (Nkind (Prefix (gnat_node)) == N_Identifier
1162             && !Is_Constrained (Etype (Prefix (gnat_node)))
1163             && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1164           gnat_param = Entity (Prefix (gnat_node));
1165         gnu_type = TREE_TYPE (gnu_prefix);
1166         prefix_unused = true;
1167         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1168
1169         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1170           {
1171             int ndim;
1172             tree gnu_type_temp;
1173
1174             for (ndim = 1, gnu_type_temp = gnu_type;
1175                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1176                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1177                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1178               ;
1179
1180             Dimension = ndim + 1 - Dimension;
1181           }
1182
1183         for (i = 1; i < Dimension; i++)
1184           gnu_type = TREE_TYPE (gnu_type);
1185
1186         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1187
1188         /* When not optimizing, look up the slot associated with the parameter
1189            and the dimension in the cache and create a new one on failure.  */
1190         if (!optimize && Present (gnat_param))
1191           {
1192             for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
1193               if (pa->id == gnat_param && pa->dim == Dimension)
1194                 break;
1195
1196             if (!pa)
1197               {
1198                 pa = GGC_CNEW (struct parm_attr);
1199                 pa->id = gnat_param;
1200                 pa->dim = Dimension;
1201                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1202               }
1203           }
1204
1205         /* Return the cached expression or build a new one.  */
1206         if (attribute == Attr_First)
1207           {
1208             if (pa && pa->first)
1209               {
1210                 gnu_result = pa->first;
1211                 break;
1212               }
1213
1214             gnu_result
1215               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1216           }
1217
1218         else if (attribute == Attr_Last)
1219           {
1220             if (pa && pa->last)
1221               {
1222                 gnu_result = pa->last;
1223                 break;
1224               }
1225
1226             gnu_result
1227               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1228           }
1229
1230         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1231           {
1232             if (pa && pa->length)
1233               {
1234                 gnu_result = pa->length;
1235                 break;
1236               }
1237             else
1238               {
1239                 tree gnu_compute_type
1240                   = signed_or_unsigned_type_for
1241                       (0, get_base_type (gnu_result_type));
1242
1243                 tree index_type
1244                   = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1245                 tree lb
1246                   = convert (gnu_compute_type, TYPE_MIN_VALUE (index_type));
1247                 tree hb
1248                   = convert (gnu_compute_type, TYPE_MAX_VALUE (index_type));
1249
1250                 /* We used to compute the length as max (hb - lb + 1, 0),
1251                    which could overflow for some cases of empty arrays, e.g.
1252                    when lb == index_type'first.
1253
1254                    We now compute it as (hb < lb) ? 0 : hb - lb + 1, which
1255                    could overflow as well, but only for extremely large arrays
1256                    which we expect never to encounter in practice.  */
1257
1258                 gnu_result
1259                   = build3
1260                     (COND_EXPR, gnu_compute_type,
1261                      build_binary_op (LT_EXPR, gnu_compute_type, hb, lb),
1262                      convert (gnu_compute_type, integer_zero_node),
1263                      build_binary_op
1264                      (PLUS_EXPR, gnu_compute_type,
1265                       build_binary_op (MINUS_EXPR, gnu_compute_type, hb, lb),
1266                       convert (gnu_compute_type, integer_one_node)));
1267               }
1268           }
1269
1270         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1271            handling.  Note that these attributes could not have been used on
1272            an unconstrained array type.  */
1273         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
1274                                                      gnu_prefix);
1275
1276         /* Cache the expression we have just computed.  Since we want to do it
1277            at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1278            create the temporary.  */
1279         if (pa)
1280           {
1281             gnu_result
1282               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1283             TREE_SIDE_EFFECTS (gnu_result) = 1;
1284             TREE_INVARIANT (gnu_result) = 1;
1285             if (attribute == Attr_First)
1286               pa->first = gnu_result;
1287             else if (attribute == Attr_Last)
1288               pa->last = gnu_result;
1289             else
1290               pa->length = gnu_result;
1291           }
1292         break;
1293       }
1294
1295     case Attr_Bit_Position:
1296     case Attr_Position:
1297     case Attr_First_Bit:
1298     case Attr_Last_Bit:
1299     case Attr_Bit:
1300       {
1301         HOST_WIDE_INT bitsize;
1302         HOST_WIDE_INT bitpos;
1303         tree gnu_offset;
1304         tree gnu_field_bitpos;
1305         tree gnu_field_offset;
1306         tree gnu_inner;
1307         enum machine_mode mode;
1308         int unsignedp, volatilep;
1309
1310         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1311         gnu_prefix = remove_conversions (gnu_prefix, true);
1312         prefix_unused = true;
1313
1314         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1315            the result is 0.  Don't allow 'Bit on a bare component, though. */
1316         if (attribute == Attr_Bit
1317             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1318             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1319           {
1320             gnu_result = integer_zero_node;
1321             break;
1322           }
1323
1324         else
1325           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1326                       || (attribute == Attr_Bit_Position
1327                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1328
1329         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1330                              &mode, &unsignedp, &volatilep, false);
1331
1332         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1333           {
1334             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1335             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1336
1337             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1338                  TREE_CODE (gnu_inner) == COMPONENT_REF
1339                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1340                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1341               {
1342                 gnu_field_bitpos
1343                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1344                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1345                 gnu_field_offset
1346                   = size_binop (PLUS_EXPR, gnu_field_offset,
1347                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1348               }
1349           }
1350         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1351           {
1352             gnu_field_bitpos = bit_position (gnu_prefix);
1353             gnu_field_offset = byte_position (gnu_prefix);
1354           }
1355         else
1356           {
1357             gnu_field_bitpos = bitsize_zero_node;
1358             gnu_field_offset = size_zero_node;
1359           }
1360
1361         switch (attribute)
1362           {
1363           case Attr_Position:
1364             gnu_result = gnu_field_offset;
1365             break;
1366
1367           case Attr_First_Bit:
1368           case Attr_Bit:
1369             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1370             break;
1371
1372           case Attr_Last_Bit:
1373             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1374             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1375                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1376             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1377                                      bitsize_one_node);
1378             break;
1379
1380           case Attr_Bit_Position:
1381             gnu_result = gnu_field_bitpos;
1382             break;
1383                 }
1384
1385         /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1386            we are handling. */
1387         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1388         break;
1389       }
1390
1391     case Attr_Min:
1392     case Attr_Max:
1393       {
1394         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1395         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1396
1397         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1398         gnu_result = build_binary_op (attribute == Attr_Min
1399                                       ? MIN_EXPR : MAX_EXPR,
1400                                       gnu_result_type, gnu_lhs, gnu_rhs);
1401       }
1402       break;
1403
1404     case Attr_Passed_By_Reference:
1405       gnu_result = size_int (default_pass_by_ref (gnu_type)
1406                              || must_pass_by_ref (gnu_type));
1407       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1408       break;
1409
1410     case Attr_Component_Size:
1411       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1412           && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1413               == RECORD_TYPE)
1414           && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1415         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1416
1417       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1418       gnu_type = TREE_TYPE (gnu_prefix);
1419
1420       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1421         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1422
1423       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1424              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1425         gnu_type = TREE_TYPE (gnu_type);
1426
1427       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1428
1429       /* Note this size cannot be self-referential.  */
1430       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1431       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1432       prefix_unused = true;
1433       break;
1434
1435     case Attr_Null_Parameter:
1436       /* This is just a zero cast to the pointer type for
1437          our prefix and dereferenced.  */
1438       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1439       gnu_result
1440         = build_unary_op (INDIRECT_REF, NULL_TREE,
1441                           convert (build_pointer_type (gnu_result_type),
1442                                    integer_zero_node));
1443       TREE_PRIVATE (gnu_result) = 1;
1444       break;
1445
1446     case Attr_Mechanism_Code:
1447       {
1448         int code;
1449         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1450
1451         prefix_unused = true;
1452         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1453         if (Present (Expressions (gnat_node)))
1454           {
1455             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1456
1457             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1458                  i--, gnat_obj = Next_Formal (gnat_obj))
1459               ;
1460           }
1461
1462         code = Mechanism (gnat_obj);
1463         if (code == Default)
1464           code = ((present_gnu_tree (gnat_obj)
1465                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1466                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1467                             == PARM_DECL)
1468                            && (DECL_BY_COMPONENT_PTR_P
1469                                (get_gnu_tree (gnat_obj))))))
1470                   ? By_Reference : By_Copy);
1471         gnu_result = convert (gnu_result_type, size_int (- code));
1472       }
1473       break;
1474
1475     default:
1476       /* Say we have an unimplemented attribute.  Then set the value to be
1477          returned to be a zero and hope that's something we can convert to the
1478          type of this attribute.  */
1479       post_error ("unimplemented attribute", gnat_node);
1480       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1481       gnu_result = integer_zero_node;
1482       break;
1483     }
1484
1485   /* If this is an attribute where the prefix was unused, force a use of it if
1486      it has a side-effect.  But don't do it if the prefix is just an entity
1487      name.  However, if an access check is needed, we must do it.  See second
1488      example in AARM 11.6(5.e). */
1489   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1490       && !Is_Entity_Name (Prefix (gnat_node)))
1491     gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1492                               gnu_prefix, gnu_result);
1493
1494   *gnu_result_type_p = gnu_result_type;
1495   return gnu_result;
1496 }
1497 \f
1498 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1499    to a GCC tree, which is returned.  */
1500
1501 static tree
1502 Case_Statement_to_gnu (Node_Id gnat_node)
1503 {
1504   tree gnu_result;
1505   tree gnu_expr;
1506   Node_Id gnat_when;
1507
1508   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1509   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1510
1511   /*  The range of values in a case statement is determined by the rules in
1512       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1513       of the expression. One exception arises in the case of a simple name that
1514       is parenthesized. This still has the Etype of the name, but since it is
1515       not a name, para 7 does not apply, and we need to go to the base type.
1516       This is the only case where parenthesization affects the dynamic
1517       semantics (i.e. the range of possible values at runtime that is covered
1518       by the others alternative.
1519
1520       Another exception is if the subtype of the expression is non-static.  In
1521       that case, we also have to use the base type.  */
1522   if (Paren_Count (Expression (gnat_node)) != 0
1523       || !Is_OK_Static_Subtype (Underlying_Type
1524                                 (Etype (Expression (gnat_node)))))
1525     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1526
1527   /* We build a SWITCH_EXPR that contains the code with interspersed
1528      CASE_LABEL_EXPRs for each label.  */
1529
1530   push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ());
1531   start_stmt_group ();
1532   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1533        Present (gnat_when);
1534        gnat_when = Next_Non_Pragma (gnat_when))
1535     {
1536       Node_Id gnat_choice;
1537       int choices_added = 0;
1538
1539       /* First compile all the different case choices for the current WHEN
1540          alternative.  */
1541       for (gnat_choice = First (Discrete_Choices (gnat_when));
1542            Present (gnat_choice); gnat_choice = Next (gnat_choice))
1543         {
1544           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1545
1546           switch (Nkind (gnat_choice))
1547             {
1548             case N_Range:
1549               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1550               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1551               break;
1552
1553             case N_Subtype_Indication:
1554               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1555                                                 (Constraint (gnat_choice))));
1556               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1557                                                   (Constraint (gnat_choice))));
1558               break;
1559
1560             case N_Identifier:
1561             case N_Expanded_Name:
1562               /* This represents either a subtype range or a static value of
1563                  some kind; Ekind says which.  */
1564               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1565                 {
1566                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1567
1568                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1569                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1570                   break;
1571                 }
1572
1573               /* ... fall through ... */
1574
1575             case N_Character_Literal:
1576             case N_Integer_Literal:
1577               gnu_low = gnat_to_gnu (gnat_choice);
1578               break;
1579
1580             case N_Others_Choice:
1581               break;
1582
1583             default:
1584               gcc_unreachable ();
1585             }
1586
1587           /* If the case value is a subtype that raises Constraint_Error at
1588              run-time because of a wrong bound, then gnu_low or gnu_high is
1589              not transtaleted into an INTEGER_CST.  In such a case, we need
1590              to ensure that the when statement is not added in the tree,
1591              otherwise it will crash the gimplifier.  */
1592           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
1593               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
1594             {
1595               add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
1596                                           gnu_low, gnu_high,
1597                                           create_artificial_label ()),
1598                                   gnat_choice);
1599               choices_added++;
1600             }
1601         }
1602
1603       /* Push a binding level here in case variables are declared as we want
1604          them to be local to this set of statements instead of to the block
1605          containing the Case statement.  */
1606       if (choices_added > 0)
1607         {
1608           add_stmt (build_stmt_group (Statements (gnat_when), true));
1609           add_stmt (build1 (GOTO_EXPR, void_type_node,
1610                             TREE_VALUE (gnu_switch_label_stack)));
1611         }
1612     }
1613
1614   /* Now emit a definition of the label all the cases branched to. */
1615   add_stmt (build1 (LABEL_EXPR, void_type_node,
1616                     TREE_VALUE (gnu_switch_label_stack)));
1617   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
1618                        end_stmt_group (), NULL_TREE);
1619   pop_stack (&gnu_switch_label_stack);
1620
1621   return gnu_result;
1622 }
1623 \f
1624 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
1625    to a GCC tree, which is returned.  */
1626
1627 static tree
1628 Loop_Statement_to_gnu (Node_Id gnat_node)
1629 {
1630   /* ??? It would be nice to use "build" here, but there's no build5.  */
1631   tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
1632                                  NULL_TREE, NULL_TREE, NULL_TREE);
1633   tree gnu_loop_var = NULL_TREE;
1634   Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
1635   tree gnu_cond_expr = NULL_TREE;
1636   tree gnu_result;
1637
1638   TREE_TYPE (gnu_loop_stmt) = void_type_node;
1639   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
1640   LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label ();
1641   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
1642   Sloc_to_locus (Sloc (End_Label (gnat_node)),
1643                  &DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt)));
1644
1645   /* Save the end label of this LOOP_STMT in a stack so that the corresponding
1646      N_Exit_Statement can find it.  */
1647   push_stack (&gnu_loop_label_stack, NULL_TREE,
1648               LOOP_STMT_LABEL (gnu_loop_stmt));
1649
1650   /* Set the condition that under which the loop should continue.
1651      For "LOOP .... END LOOP;" the condition is always true.  */
1652   if (No (gnat_iter_scheme))
1653     ;
1654   /* The case "WHILE condition LOOP ..... END LOOP;" */
1655   else if (Present (Condition (gnat_iter_scheme)))
1656     LOOP_STMT_TOP_COND (gnu_loop_stmt)
1657       = gnat_to_gnu (Condition (gnat_iter_scheme));
1658   else
1659     {
1660       /* We have an iteration scheme.  */
1661       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
1662       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
1663       Entity_Id gnat_type = Etype (gnat_loop_var);
1664       tree gnu_type = get_unpadded_type (gnat_type);
1665       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
1666       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
1667       bool reversep = Reverse_Present (gnat_loop_spec);
1668       tree gnu_first = reversep ? gnu_high : gnu_low;
1669       tree gnu_last = reversep ? gnu_low : gnu_high;
1670       enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
1671       tree gnu_base_type = get_base_type (gnu_type);
1672       tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
1673                         : TYPE_MAX_VALUE (gnu_base_type));
1674
1675       /* We know the loop variable will not overflow if GNU_LAST is a constant
1676          and is not equal to GNU_LIMIT.  If it might overflow, we have to move
1677          the limit test to the end of the loop.  In that case, we have to test
1678          for an empty loop outside the loop.  */
1679       if (TREE_CODE (gnu_last) != INTEGER_CST
1680           || TREE_CODE (gnu_limit) != INTEGER_CST
1681           || tree_int_cst_equal (gnu_last, gnu_limit))
1682         {
1683           gnu_cond_expr
1684             = build3 (COND_EXPR, void_type_node,
1685                       build_binary_op (LE_EXPR, integer_type_node,
1686                                        gnu_low, gnu_high),
1687                       NULL_TREE, alloc_stmt_list ());
1688           set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
1689         }
1690
1691       /* Open a new nesting level that will surround the loop to declare the
1692          loop index variable.  */
1693       start_stmt_group ();
1694       gnat_pushlevel ();
1695
1696       /* Declare the loop index and set it to its initial value.  */
1697       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
1698       if (DECL_BY_REF_P (gnu_loop_var))
1699         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
1700
1701       /* The loop variable might be a padded type, so use `convert' to get a
1702          reference to the inner variable if so.  */
1703       gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
1704
1705       /* Set either the top or bottom exit condition as appropriate depending
1706          on whether or not we know an overflow cannot occur. */
1707       if (gnu_cond_expr)
1708         LOOP_STMT_BOT_COND (gnu_loop_stmt)
1709           = build_binary_op (NE_EXPR, integer_type_node,
1710                              gnu_loop_var, gnu_last);
1711       else
1712         LOOP_STMT_TOP_COND (gnu_loop_stmt)
1713           = build_binary_op (end_code, integer_type_node,
1714                              gnu_loop_var, gnu_last);
1715
1716       LOOP_STMT_UPDATE (gnu_loop_stmt)
1717         = build_binary_op (reversep ? PREDECREMENT_EXPR
1718                            : PREINCREMENT_EXPR,
1719                            TREE_TYPE (gnu_loop_var),
1720                            gnu_loop_var,
1721                            convert (TREE_TYPE (gnu_loop_var),
1722                                     integer_one_node));
1723       set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
1724                           gnat_iter_scheme);
1725     }
1726
1727   /* If the loop was named, have the name point to this loop.  In this case,
1728      the association is not a ..._DECL node, but the end label from this
1729      LOOP_STMT. */
1730   if (Present (Identifier (gnat_node)))
1731     save_gnu_tree (Entity (Identifier (gnat_node)),
1732                    LOOP_STMT_LABEL (gnu_loop_stmt), true);
1733
1734   /* Make the loop body into its own block, so any allocated storage will be
1735      released every iteration.  This is needed for stack allocation.  */
1736   LOOP_STMT_BODY (gnu_loop_stmt)
1737     = build_stmt_group (Statements (gnat_node), true);
1738
1739   /* If we declared a variable, then we are in a statement group for that
1740      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
1741   if (gnu_loop_var)
1742     {
1743       add_stmt (gnu_loop_stmt);
1744       gnat_poplevel ();
1745       gnu_loop_stmt = end_stmt_group ();
1746     }
1747
1748   /* If we have an outer COND_EXPR, that's our result and this loop is its
1749      "true" statement.  Otherwise, the result is the LOOP_STMT. */
1750   if (gnu_cond_expr)
1751     {
1752       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
1753       gnu_result = gnu_cond_expr;
1754       recalculate_side_effects (gnu_cond_expr);
1755     }
1756   else
1757     gnu_result = gnu_loop_stmt;
1758
1759   pop_stack (&gnu_loop_label_stack);
1760
1761   return gnu_result;
1762 }
1763 \f
1764 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
1765    handler for the current function.  */
1766
1767 /* This is implemented by issuing a call to the appropriate VMS specific
1768    builtin.  To avoid having VMS specific sections in the global gigi decls
1769    array, we maintain the decls of interest here.  We can't declare them
1770    inside the function because we must mark them never to be GC'd, which we
1771    can only do at the global level.  */
1772
1773 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
1774 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
1775
1776 static void
1777 establish_gnat_vms_condition_handler (void)
1778 {
1779   tree establish_stmt;
1780
1781   /* Elaborate the required decls on the first call.  Check on the decl for
1782      the gnat condition handler to decide, as this is one we create so we are
1783      sure that it will be non null on subsequent calls.  The builtin decl is
1784      looked up so remains null on targets where it is not implemented yet.  */
1785   if (gnat_vms_condition_handler_decl == NULL_TREE)
1786     {
1787       vms_builtin_establish_handler_decl
1788         = builtin_decl_for
1789           (get_identifier ("__builtin_establish_vms_condition_handler"));
1790
1791       gnat_vms_condition_handler_decl
1792         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
1793                                NULL_TREE,
1794                                build_function_type_list (integer_type_node,
1795                                                          ptr_void_type_node,
1796                                                          ptr_void_type_node,
1797                                                          NULL_TREE),
1798                                NULL_TREE, 0, 1, 1, 0, Empty);
1799     }
1800
1801   /* Do nothing if the establish builtin is not available, which might happen
1802      on targets where the facility is not implemented.  */
1803   if (vms_builtin_establish_handler_decl == NULL_TREE)
1804     return;
1805
1806   establish_stmt
1807     = build_call_1_expr (vms_builtin_establish_handler_decl,
1808                          build_unary_op
1809                          (ADDR_EXPR, NULL_TREE,
1810                           gnat_vms_condition_handler_decl));
1811
1812   add_stmt (establish_stmt);
1813 }
1814 \f
1815 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
1816    don't return anything.  */
1817
1818 static void
1819 Subprogram_Body_to_gnu (Node_Id gnat_node)
1820 {
1821   /* Defining identifier of a parameter to the subprogram.  */
1822   Entity_Id gnat_param;
1823   /* The defining identifier for the subprogram body. Note that if a
1824      specification has appeared before for this body, then the identifier
1825      occurring in that specification will also be a defining identifier and all
1826      the calls to this subprogram will point to that specification.  */
1827   Entity_Id gnat_subprog_id
1828     = (Present (Corresponding_Spec (gnat_node))
1829        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
1830   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
1831   tree gnu_subprog_decl;
1832   /* The FUNCTION_TYPE node corresponding to the subprogram spec.  */
1833   tree gnu_subprog_type;
1834   tree gnu_cico_list;
1835   tree gnu_result;
1836   VEC(parm_attr,gc) *cache;
1837
1838   /* If this is a generic object or if it has been eliminated,
1839      ignore it.  */
1840   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
1841       || Ekind (gnat_subprog_id) == E_Generic_Function
1842       || Is_Eliminated (gnat_subprog_id))
1843     return;
1844
1845   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
1846      the already-elaborated tree node.  However, if this subprogram had its
1847      elaboration deferred, we will already have made a tree node for it.  So
1848      treat it as not being defined in that case.  Such a subprogram cannot
1849      have an address clause or a freeze node, so this test is safe, though it
1850      does disable some otherwise-useful error checking.  */
1851   gnu_subprog_decl
1852     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
1853                           Acts_As_Spec (gnat_node)
1854                           && !present_gnu_tree (gnat_subprog_id));
1855
1856   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
1857
1858   /* Propagate the debug mode.  */
1859   if (!Needs_Debug_Info (gnat_subprog_id))
1860     DECL_IGNORED_P (gnu_subprog_decl) = 1;
1861
1862   /* Set the line number in the decl to correspond to that of the body so that
1863      the line number notes are written correctly.  */
1864   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
1865
1866   /* Initialize the information structure for the function.  */
1867   allocate_struct_function (gnu_subprog_decl, false);
1868   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
1869     = GGC_CNEW (struct language_function);
1870
1871   begin_subprog_body (gnu_subprog_decl);
1872   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1873
1874   /* If there are Out parameters, we need to ensure that the return statement
1875      properly copies them out.  We do this by making a new block and converting
1876      any inner return into a goto to a label at the end of the block.  */
1877   push_stack (&gnu_return_label_stack, NULL_TREE,
1878               gnu_cico_list ? create_artificial_label () : NULL_TREE);
1879
1880   /* Get a tree corresponding to the code for the subprogram.  */
1881   start_stmt_group ();
1882   gnat_pushlevel ();
1883
1884   /* See if there are any parameters for which we don't yet have GCC entities.
1885      These must be for Out parameters for which we will be making VAR_DECL
1886      nodes here.  Fill them in to TYPE_CI_CO_LIST, which must contain the empty
1887      entry as well.  We can match up the entries because TYPE_CI_CO_LIST is in
1888      the order of the parameters.  */
1889   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
1890        Present (gnat_param);
1891        gnat_param = Next_Formal_With_Extras (gnat_param))
1892     if (!present_gnu_tree (gnat_param))
1893       {
1894         /* Skip any entries that have been already filled in; they must
1895            correspond to In Out parameters.  */
1896         for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
1897              gnu_cico_list = TREE_CHAIN (gnu_cico_list))
1898           ;
1899
1900         /* Do any needed references for padded types.  */
1901         TREE_VALUE (gnu_cico_list)
1902           = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
1903                      gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
1904       }
1905
1906   /* On VMS, establish our condition handler to possibly turn a condition into
1907      the corresponding exception if the subprogram has a foreign convention or
1908      is exported.
1909
1910      To ensure proper execution of local finalizations on condition instances,
1911      we must turn a condition into the corresponding exception even if there
1912      is no applicable Ada handler, and need at least one condition handler per
1913      possible call chain involving GNAT code.  OTOH, establishing the handler
1914      has a cost so we want to minimize the number of subprograms into which
1915      this happens.  The foreign or exported condition is expected to satisfy
1916      all the constraints.  */
1917   if (TARGET_ABI_OPEN_VMS
1918       && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node)))
1919     establish_gnat_vms_condition_handler ();
1920
1921   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
1922
1923   /* Generate the code of the subprogram itself.  A return statement will be
1924      present and any Out parameters will be handled there.  */
1925   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
1926   gnat_poplevel ();
1927   gnu_result = end_stmt_group ();
1928
1929   /* If we populated the parameter attributes cache, we need to make sure
1930      that the cached expressions are evaluated on all possible paths.  */
1931   cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
1932   if (cache)
1933     {
1934       struct parm_attr *pa;
1935       int i;
1936
1937       start_stmt_group ();
1938
1939       for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
1940         {
1941           if (pa->first)
1942             add_stmt (pa->first);
1943           if (pa->last)
1944             add_stmt (pa->last);
1945           if (pa->length)
1946             add_stmt (pa->length);
1947         }
1948
1949       add_stmt (gnu_result);
1950       gnu_result = end_stmt_group ();
1951     }
1952
1953   /* If we made a special return label, we need to make a block that contains
1954      the definition of that label and the copying to the return value.  That
1955      block first contains the function, then the label and copy statement.  */
1956   if (TREE_VALUE (gnu_return_label_stack))
1957     {
1958       tree gnu_retval;
1959
1960       start_stmt_group ();
1961       gnat_pushlevel ();
1962       add_stmt (gnu_result);
1963       add_stmt (build1 (LABEL_EXPR, void_type_node,
1964                         TREE_VALUE (gnu_return_label_stack)));
1965
1966       gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1967       if (list_length (gnu_cico_list) == 1)
1968         gnu_retval = TREE_VALUE (gnu_cico_list);
1969       else
1970         gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
1971                                              gnu_cico_list);
1972
1973       if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
1974         gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
1975
1976       add_stmt_with_node
1977         (build_return_expr (DECL_RESULT (gnu_subprog_decl), gnu_retval),
1978          gnat_node);
1979       gnat_poplevel ();
1980       gnu_result = end_stmt_group ();
1981     }
1982
1983   pop_stack (&gnu_return_label_stack);
1984
1985   /* Set the end location.  */
1986   Sloc_to_locus
1987     ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
1988       ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
1989       : Sloc (gnat_node)),
1990      &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
1991
1992   end_subprog_body (gnu_result);
1993
1994   /* Disconnect the trees for parameters that we made variables for from the
1995      GNAT entities since these are unusable after we end the function.  */
1996   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
1997        Present (gnat_param);
1998        gnat_param = Next_Formal_With_Extras (gnat_param))
1999     if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
2000       save_gnu_tree (gnat_param, NULL_TREE, false);
2001
2002   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2003     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2004
2005   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2006 }
2007 \f
2008 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2009    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2010    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2011    If GNU_TARGET is non-null, this must be a function call and the result
2012    of the call is to be placed into that object.  */
2013
2014 static tree
2015 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2016 {
2017   tree gnu_result;
2018   /* The GCC node corresponding to the GNAT subprogram name.  This can either
2019      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2020      or an indirect reference expression (an INDIRECT_REF node) pointing to a
2021      subprogram.  */
2022   tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
2023   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2024   tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
2025   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE,
2026                                           gnu_subprog_node);
2027   Entity_Id gnat_formal;
2028   Node_Id gnat_actual;
2029   tree gnu_actual_list = NULL_TREE;
2030   tree gnu_name_list = NULL_TREE;
2031   tree gnu_before_list = NULL_TREE;
2032   tree gnu_after_list = NULL_TREE;
2033   tree gnu_subprog_call;
2034
2035   switch (Nkind (Name (gnat_node)))
2036     {
2037     case N_Identifier:
2038     case N_Operator_Symbol:
2039     case N_Expanded_Name:
2040     case N_Attribute_Reference:
2041       if (Is_Eliminated (Entity (Name (gnat_node))))
2042         Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
2043     }
2044
2045   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2046
2047   /* If we are calling a stubbed function, make this into a raise of
2048      Program_Error.  Elaborate all our args first.  */
2049   if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
2050       && DECL_STUBBED_P (gnu_subprog_node))
2051     {
2052       for (gnat_actual = First_Actual (gnat_node);
2053            Present (gnat_actual);
2054            gnat_actual = Next_Actual (gnat_actual))
2055         add_stmt (gnat_to_gnu (gnat_actual));
2056
2057       {
2058         tree call_expr
2059           = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node,
2060                               N_Raise_Program_Error);
2061
2062         if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
2063           {
2064             *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
2065             return build1 (NULL_EXPR, *gnu_result_type_p, call_expr);
2066           }
2067         else
2068           return call_expr;
2069       }
2070     }
2071
2072   /* If we are calling by supplying a pointer to a target, set up that
2073      pointer as the first argument.  Use GNU_TARGET if one was passed;
2074      otherwise, make a target by building a variable of the maximum size
2075      of the type.  */
2076   if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
2077     {
2078       tree gnu_real_ret_type
2079         = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
2080
2081       if (!gnu_target)
2082         {
2083           tree gnu_obj_type
2084             = maybe_pad_type (gnu_real_ret_type,
2085                               max_size (TYPE_SIZE (gnu_real_ret_type), true),
2086                               0, Etype (Name (gnat_node)), "PAD", false,
2087                               false, false);
2088
2089           /* ??? We may be about to create a static temporary if we happen to
2090              be at the global binding level.  That's a regression from what
2091              the 3.x back-end would generate in the same situation, but we
2092              don't have a mechanism in Gigi for creating automatic variables
2093              in the elaboration routines.  */
2094           gnu_target
2095             = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
2096                                NULL, false, false, false, false, NULL,
2097                                gnat_node);
2098         }
2099
2100       gnu_actual_list
2101         = tree_cons (NULL_TREE,
2102                      build_unary_op (ADDR_EXPR, NULL_TREE,
2103                                      unchecked_convert (gnu_real_ret_type,
2104                                                         gnu_target,
2105                                                         false)),
2106                      NULL_TREE);
2107
2108     }
2109
2110   /* The only way we can be making a call via an access type is if Name is an
2111      explicit dereference.  In that case, get the list of formal args from the
2112      type the access type is pointing to.  Otherwise, get the formals from
2113      entity being called.  */
2114   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2115     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2116   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2117     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2118     gnat_formal = 0;
2119   else
2120     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2121
2122   /* Create the list of the actual parameters as GCC expects it, namely a chain
2123      of TREE_LIST nodes in which the TREE_VALUE field of each node is a
2124      parameter-expression and the TREE_PURPOSE field is null.  Skip Out
2125      parameters not passed by reference and don't need to be copied in.  */
2126   for (gnat_actual = First_Actual (gnat_node);
2127        Present (gnat_actual);
2128        gnat_formal = Next_Formal_With_Extras (gnat_formal),
2129        gnat_actual = Next_Actual (gnat_actual))
2130     {
2131       tree gnu_formal
2132         = (present_gnu_tree (gnat_formal)
2133            ? get_gnu_tree (gnat_formal) : NULL_TREE);
2134       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2135       /* We must suppress conversions that can cause the creation of a
2136          temporary in the Out or In Out case because we need the real
2137          object in this case, either to pass its address if it's passed
2138          by reference or as target of the back copy done after the call
2139          if it uses the copy-in copy-out mechanism.  We do it in the In
2140          case too, except for an unchecked conversion because it alone
2141          can cause the actual to be misaligned and the addressability
2142          test is applied to the real object.  */
2143       bool suppress_type_conversion
2144         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2145             && Ekind (gnat_formal) != E_In_Parameter)
2146            || (Nkind (gnat_actual) == N_Type_Conversion
2147                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2148       Node_Id gnat_name = (suppress_type_conversion
2149                            ? Expression (gnat_actual) : gnat_actual);
2150       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2151       tree gnu_actual;
2152
2153       /* If it's possible we may need to use this expression twice, make sure
2154          that any side-effects are handled via SAVE_EXPRs.  Likewise if we need
2155          to force side-effects before the call.
2156          ??? This is more conservative than we need since we don't need to do
2157          this for pass-by-ref with no conversion.  */
2158       if (Ekind (gnat_formal) != E_In_Parameter)
2159         gnu_name = gnat_stabilize_reference (gnu_name, true);
2160
2161       /* If we are passing a non-addressable parameter by reference, pass the
2162          address of a copy.  In the Out or In Out case, set up to copy back
2163          out after the call.  */
2164       if (gnu_formal
2165           && (DECL_BY_REF_P (gnu_formal)
2166               || (TREE_CODE (gnu_formal) == PARM_DECL
2167                   && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2168                       || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2169           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2170           && !addressable_p (gnu_name, gnu_name_type))
2171         {
2172           tree gnu_copy = gnu_name, gnu_temp;
2173
2174           /* If the type is by_reference, a copy is not allowed.  */
2175           if (Is_By_Reference_Type (Etype (gnat_formal)))
2176             post_error
2177               ("misaligned actual cannot be passed by reference", gnat_actual);
2178
2179           /* For users of Starlet we issue a warning because the
2180              interface apparently assumes that by-ref parameters
2181              outlive the procedure invocation.  The code still
2182              will not work as intended, but we cannot do much
2183              better since other low-level parts of the back-end
2184              would allocate temporaries at will because of the
2185              misalignment if we did not do so here.  */
2186           else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2187             {
2188               post_error
2189                 ("?possible violation of implicit assumption", gnat_actual);
2190               post_error_ne
2191                 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
2192                  Entity (Name (gnat_node)));
2193               post_error_ne ("?because of misalignment of &", gnat_actual,
2194                              gnat_formal);
2195             }
2196
2197           /* Remove any unpadding from the object and reset the copy.  */
2198           if (TREE_CODE (gnu_name) == COMPONENT_REF
2199               && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
2200                    == RECORD_TYPE)
2201                   && (TYPE_IS_PADDING_P
2202                       (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
2203             gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
2204
2205           /* Otherwise convert to the nominal type of the object if it's
2206              a record type.  There are several cases in which we need to
2207              make the temporary using this type instead of the actual type
2208              of the object if they are distinct, because the expectations
2209              of the callee would otherwise not be met:
2210                - if it's a justified modular type,
2211                - if the actual type is a packed version of it.  */
2212           else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2213                    && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
2214                        || larger_record_type_p (gnu_name_type,
2215                                                 TREE_TYPE (gnu_name))))
2216             gnu_name = convert (gnu_name_type, gnu_name);
2217
2218           /* Make a SAVE_EXPR to both properly account for potential side
2219              effects and handle the creation of a temporary copy.  Special
2220              code in gnat_gimplify_expr ensures that the same temporary is
2221              used as the object and copied back after the call if needed.  */
2222           gnu_name = build1 (SAVE_EXPR, TREE_TYPE (gnu_name), gnu_name);
2223           TREE_SIDE_EFFECTS (gnu_name) = 1;
2224           TREE_INVARIANT (gnu_name) = 1;
2225
2226           /* Set up to move the copy back to the original.  */
2227           if (Ekind (gnat_formal) != E_In_Parameter)
2228             {
2229               gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy,
2230                                           gnu_name);
2231               set_expr_location_from_node (gnu_temp, gnat_actual);
2232               append_to_statement_list (gnu_temp, &gnu_after_list);
2233             }
2234         }
2235
2236       /* Start from the real object and build the actual.  */
2237       gnu_actual = gnu_name;
2238
2239       /* If this was a procedure call, we may not have removed any padding.
2240          So do it here for the part we will use as an input, if any.  */
2241       if (Ekind (gnat_formal) != E_Out_Parameter
2242           && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2243           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2244         gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2245                               gnu_actual);
2246
2247       /* Do any needed conversions for the actual and make sure that it is
2248          in range of the formal's type.  */
2249       if (suppress_type_conversion)
2250         {
2251           /* Put back the conversion we suppressed above in the computation
2252              of the real object.  Note that we treat a conversion between
2253              aggregate types as if it is an unchecked conversion here.  */
2254           gnu_actual
2255             = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2256                                  gnu_actual,
2257                                  (Nkind (gnat_actual)
2258                                   == N_Unchecked_Type_Conversion)
2259                                  && No_Truncation (gnat_actual));
2260
2261           if (Ekind (gnat_formal) != E_Out_Parameter
2262               && Do_Range_Check (gnat_actual))
2263             gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
2264         }
2265       else
2266         {
2267           if (Ekind (gnat_formal) != E_Out_Parameter
2268               && Do_Range_Check (gnat_actual))
2269             gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
2270
2271           /* We may have suppressed a conversion to the Etype of the actual
2272              since the parent is a procedure call.  So put it back here.
2273              ??? We use the reverse order compared to the case above because
2274              of an awkward interaction with the check and actually don't put
2275              back the conversion at all if a check is emitted.  This is also
2276              done for the conversion to the formal's type just below.  */
2277           if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2278             gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2279                                   gnu_actual);
2280         }
2281
2282       if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2283         gnu_actual = convert (gnu_formal_type, gnu_actual);
2284
2285       /* Unless this is an In parameter, we must remove any justified modular
2286          building from GNU_NAME to get an lvalue.  */
2287       if (Ekind (gnat_formal) != E_In_Parameter
2288           && TREE_CODE (gnu_name) == CONSTRUCTOR
2289           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2290           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2291         gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
2292                             gnu_name);
2293
2294       /* If we have not saved a GCC object for the formal, it means it is an
2295          Out parameter not passed by reference and that does not need to be
2296          copied in. Otherwise, look at the PARM_DECL to see if it is passed by
2297          reference. */
2298       if (gnu_formal
2299           && TREE_CODE (gnu_formal) == PARM_DECL
2300           && DECL_BY_REF_P (gnu_formal))
2301         {
2302           if (Ekind (gnat_formal) != E_In_Parameter)
2303             {
2304               /* In Out or Out parameters passed by reference don't use the
2305                  copy-in copy-out mechanism so the address of the real object
2306                  must be passed to the function.  */
2307               gnu_actual = gnu_name;
2308
2309               /* If we have a padded type, be sure we've removed padding.  */
2310               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2311                   && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
2312                   && TREE_CODE (gnu_actual) != SAVE_EXPR)
2313                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2314                                       gnu_actual);
2315
2316               /* If we have the constructed subtype of an aliased object
2317                  with an unconstrained nominal subtype, the type of the
2318                  actual includes the template, although it is formally
2319                  constrained.  So we need to convert it back to the real
2320                  constructed subtype to retrieve the constrained part
2321                  and takes its address.  */
2322               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2323                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
2324                   && TREE_CODE (gnu_actual) != SAVE_EXPR
2325                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
2326                   && Is_Array_Type (Etype (gnat_actual)))
2327                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2328                                       gnu_actual);
2329             }
2330
2331           /* The symmetry of the paths to the type of an entity is broken here
2332              since arguments don't know that they will be passed by ref. */
2333           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2334           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2335         }
2336       else if (gnu_formal
2337                && TREE_CODE (gnu_formal) == PARM_DECL
2338                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
2339         {
2340           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2341           gnu_actual = maybe_implicit_deref (gnu_actual);
2342           gnu_actual = maybe_unconstrained_array (gnu_actual);
2343
2344           if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
2345               && TYPE_IS_PADDING_P (gnu_formal_type))
2346             {
2347               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2348               gnu_actual = convert (gnu_formal_type, gnu_actual);
2349             }
2350
2351           /* Take the address of the object and convert to the proper pointer
2352              type.  We'd like to actually compute the address of the beginning
2353              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2354              possibility that the ARRAY_REF might return a constant and we'd be
2355              getting the wrong address.  Neither approach is exactly correct,
2356              but this is the most likely to work in all cases.  */
2357           gnu_actual = convert (gnu_formal_type,
2358                                 build_unary_op (ADDR_EXPR, NULL_TREE,
2359                                                 gnu_actual));
2360         }
2361       else if (gnu_formal
2362                && TREE_CODE (gnu_formal) == PARM_DECL
2363                && DECL_BY_DESCRIPTOR_P (gnu_formal))
2364         {
2365           /* If arg is 'Null_Parameter, pass zero descriptor.  */
2366           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2367                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2368               && TREE_PRIVATE (gnu_actual))
2369             gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
2370                                   integer_zero_node);
2371           else
2372             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
2373                                          fill_vms_descriptor (gnu_actual,
2374                                                               gnat_formal));
2375         }
2376       else
2377         {
2378           tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
2379
2380           if (Ekind (gnat_formal) != E_In_Parameter)
2381             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
2382
2383           if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL)
2384             continue;
2385
2386           /* If this is 'Null_Parameter, pass a zero even though we are
2387              dereferencing it.  */
2388           else if (TREE_CODE (gnu_actual) == INDIRECT_REF
2389                    && TREE_PRIVATE (gnu_actual)
2390                    && host_integerp (gnu_actual_size, 1)
2391                    && 0 >= compare_tree_int (gnu_actual_size,
2392                                                    BITS_PER_WORD))
2393             gnu_actual
2394               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
2395                                    convert (gnat_type_for_size
2396                                             (tree_low_cst (gnu_actual_size, 1),
2397                                              1),
2398                                             integer_zero_node),
2399                                    false);
2400           else
2401             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
2402         }
2403
2404       gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
2405     }
2406
2407   gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type),
2408                                       gnu_subprog_addr,
2409                                       nreverse (gnu_actual_list));
2410   set_expr_location_from_node (gnu_subprog_call, gnat_node);
2411
2412   /* If we return by passing a target, the result is the target after the
2413      call.  We must not emit the call directly here because this might be
2414      evaluated as part of an expression with conditions to control whether
2415      the call should be emitted or not.  */
2416   if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
2417     {
2418       /* Conceptually, what we need is a COMPOUND_EXPR with the call followed
2419          by the target object converted to the proper type.  Doing so would
2420          potentially be very inefficient, however, as this expresssion might
2421          end up wrapped into an outer SAVE_EXPR later on, which would incur a
2422          pointless temporary copy of the whole object.
2423
2424          What we do instead is build a COMPOUND_EXPR returning the address of
2425          the target, and then dereference.  Wrapping the COMPOUND_EXPR into a
2426          SAVE_EXPR later on then only incurs a pointer copy.  */
2427
2428       tree gnu_result_type
2429         = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
2430
2431       /* Build and return
2432          (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target]  */
2433
2434       tree gnu_target_address
2435         = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_target);
2436       set_expr_location_from_node (gnu_target_address, gnat_node);
2437
2438       gnu_result
2439         = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_target_address),
2440                   gnu_subprog_call, gnu_target_address);
2441
2442       gnu_result
2443         = unchecked_convert (gnu_result_type,
2444                              build_unary_op (INDIRECT_REF, NULL_TREE,
2445                                              gnu_result),
2446                              false);
2447
2448       *gnu_result_type_p = gnu_result_type;
2449       return gnu_result;
2450     }
2451
2452   /* If it is a function call, the result is the call expression unless
2453      a target is specified, in which case we copy the result into the target
2454      and return the assignment statement.  */
2455   else if (Nkind (gnat_node) == N_Function_Call)
2456     {
2457       gnu_result = gnu_subprog_call;
2458
2459       /* If the function returns an unconstrained array or by reference,
2460          we have to de-dereference the pointer.  */
2461       if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
2462           || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
2463         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2464
2465       if (gnu_target)
2466         gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2467                                       gnu_target, gnu_result);
2468       else
2469         *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
2470
2471       return gnu_result;
2472     }
2473
2474   /* If this is the case where the GNAT tree contains a procedure call
2475      but the Ada procedure has copy in copy out parameters, the special
2476      parameter passing mechanism must be used.  */
2477   else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
2478     {
2479       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
2480          in copy out parameters.  */
2481       tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2482       int length = list_length (scalar_return_list);
2483
2484       if (length > 1)
2485         {
2486           tree gnu_name;
2487
2488           gnu_subprog_call = save_expr (gnu_subprog_call);
2489           gnu_name_list = nreverse (gnu_name_list);
2490
2491           /* If any of the names had side-effects, ensure they are all
2492              evaluated before the call.  */
2493           for (gnu_name = gnu_name_list; gnu_name;
2494                gnu_name = TREE_CHAIN (gnu_name))
2495             if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
2496               append_to_statement_list (TREE_VALUE (gnu_name),
2497                                         &gnu_before_list);
2498         }
2499
2500       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2501         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2502       else
2503         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2504
2505       for (gnat_actual = First_Actual (gnat_node);
2506            Present (gnat_actual);
2507            gnat_formal = Next_Formal_With_Extras (gnat_formal),
2508            gnat_actual = Next_Actual (gnat_actual))
2509         /* If we are dealing with a copy in copy out parameter, we must
2510            retrieve its value from the record returned in the call.  */
2511         if (!(present_gnu_tree (gnat_formal)
2512               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2513               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2514                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2515                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2516                            || (DECL_BY_DESCRIPTOR_P
2517                                (get_gnu_tree (gnat_formal))))))))
2518             && Ekind (gnat_formal) != E_In_Parameter)
2519           {
2520             /* Get the value to assign to this Out or In Out parameter.  It is
2521                either the result of the function if there is only a single such
2522                parameter or the appropriate field from the record returned.  */
2523             tree gnu_result
2524               = length == 1 ? gnu_subprog_call
2525                 : build_component_ref (gnu_subprog_call, NULL_TREE,
2526                                        TREE_PURPOSE (scalar_return_list),
2527                                        false);
2528
2529             /* If the actual is a conversion, get the inner expression, which
2530                will be the real destination, and convert the result to the
2531                type of the actual parameter.  */
2532             tree gnu_actual
2533               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
2534
2535             /* If the result is a padded type, remove the padding.  */
2536             if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
2537                 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
2538               gnu_result = convert (TREE_TYPE (TYPE_FIELDS
2539                                                (TREE_TYPE (gnu_result))),
2540                                     gnu_result);
2541
2542             /* If the actual is a type conversion, the real target object is
2543                denoted by the inner Expression and we need to convert the
2544                result to the associated type.
2545                We also need to convert our gnu assignment target to this type
2546                if the corresponding GNU_NAME was constructed from the GNAT
2547                conversion node and not from the inner Expression.  */
2548             if (Nkind (gnat_actual) == N_Type_Conversion)
2549               {
2550                 gnu_result
2551                   = convert_with_check
2552                     (Etype (Expression (gnat_actual)), gnu_result,
2553                      Do_Overflow_Check (gnat_actual),
2554                      Do_Range_Check (Expression (gnat_actual)),
2555                      Float_Truncate (gnat_actual));
2556
2557                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
2558                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
2559               }
2560
2561             /* Unchecked conversions as actuals for Out parameters are not
2562                allowed in user code because they are not variables, but do
2563                occur in front-end expansions.  The associated GNU_NAME is
2564                always obtained from the inner expression in such cases.  */
2565             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2566               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
2567                                               gnu_result,
2568                                               No_Truncation (gnat_actual));
2569             else
2570               {
2571                 if (Do_Range_Check (gnat_actual))
2572                   gnu_result = emit_range_check (gnu_result,
2573                                                  Etype (gnat_actual));
2574
2575                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2576                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
2577                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
2578               }
2579
2580             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2581                                           gnu_actual, gnu_result);
2582             set_expr_location_from_node (gnu_result, gnat_actual);
2583             append_to_statement_list (gnu_result, &gnu_before_list);
2584             scalar_return_list = TREE_CHAIN (scalar_return_list);
2585             gnu_name_list = TREE_CHAIN (gnu_name_list);
2586           }
2587         }
2588   else
2589     append_to_statement_list (gnu_subprog_call, &gnu_before_list);
2590
2591   append_to_statement_list (gnu_after_list, &gnu_before_list);
2592   return gnu_before_list;
2593 }
2594 \f
2595 /* Subroutine of gnat_to_gnu to translate gnat_node, an
2596    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
2597
2598 static tree
2599 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
2600 {
2601   tree gnu_jmpsave_decl = NULL_TREE;
2602   tree gnu_jmpbuf_decl = NULL_TREE;
2603   /* If just annotating, ignore all EH and cleanups.  */
2604   bool gcc_zcx = (!type_annotate_only
2605                   && Present (Exception_Handlers (gnat_node))
2606                   && Exception_Mechanism == Back_End_Exceptions);
2607   bool setjmp_longjmp
2608     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
2609        && Exception_Mechanism == Setjmp_Longjmp);
2610   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
2611   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
2612   tree gnu_inner_block; /* The statement(s) for the block itself.  */
2613   tree gnu_result;
2614   tree gnu_expr;
2615   Node_Id gnat_temp;
2616
2617   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
2618      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
2619      add_cleanup, and when we leave the binding, end_stmt_group will create
2620      the TRY_FINALLY_EXPR.
2621
2622      ??? The region level calls down there have been specifically put in place
2623      for a ZCX context and currently the order in which things are emitted
2624      (region/handlers) is different from the SJLJ case. Instead of putting
2625      other calls with different conditions at other places for the SJLJ case,
2626      it seems cleaner to reorder things for the SJLJ case and generalize the
2627      condition to make it not ZCX specific.
2628
2629      If there are any exceptions or cleanup processing involved, we need an
2630      outer statement group (for Setjmp_Longjmp) and binding level.  */
2631   if (binding_for_block)
2632     {
2633       start_stmt_group ();
2634       gnat_pushlevel ();
2635     }
2636
2637   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
2638      area for address of previous buffer.  Do this first since we need to have
2639      the setjmp buf known for any decls in this block.  */
2640   if (setjmp_longjmp)
2641     {
2642       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
2643                                           NULL_TREE, jmpbuf_ptr_type,
2644                                           build_call_0_expr (get_jmpbuf_decl),
2645                                           false, false, false, false, NULL,
2646                                           gnat_node);
2647       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
2648
2649       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
2650          because of the unstructured form of EH used by setjmp_longjmp, there
2651          might be forward edges going to __builtin_setjmp receivers on which
2652          it is uninitialized, although they will never be actually taken.  */
2653       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
2654       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
2655                                          NULL_TREE, jmpbuf_type,
2656                                          NULL_TREE, false, false, false, false,
2657                                          NULL, gnat_node);
2658       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
2659
2660       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
2661
2662       /* When we exit this block, restore the saved value.  */
2663       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
2664                    End_Label (gnat_node));
2665     }
2666
2667   /* If we are to call a function when exiting this block, add a cleanup
2668      to the binding level we made above.  Note that add_cleanup is FIFO
2669      so we must register this cleanup after the EH cleanup just above.  */
2670   if (at_end)
2671     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
2672                  End_Label (gnat_node));
2673
2674   /* Now build the tree for the declarations and statements inside this block.
2675      If this is SJLJ, set our jmp_buf as the current buffer.  */
2676   start_stmt_group ();
2677
2678   if (setjmp_longjmp)
2679     add_stmt (build_call_1_expr (set_jmpbuf_decl,
2680                                  build_unary_op (ADDR_EXPR, NULL_TREE,
2681                                                  gnu_jmpbuf_decl)));
2682
2683   if (Present (First_Real_Statement (gnat_node)))
2684     process_decls (Statements (gnat_node), Empty,
2685                    First_Real_Statement (gnat_node), true, true);
2686
2687   /* Generate code for each statement in the block.  */
2688   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
2689                     ? First_Real_Statement (gnat_node)
2690                     : First (Statements (gnat_node)));
2691        Present (gnat_temp); gnat_temp = Next (gnat_temp))
2692     add_stmt (gnat_to_gnu (gnat_temp));
2693   gnu_inner_block = end_stmt_group ();
2694
2695   /* Now generate code for the two exception models, if either is relevant for
2696      this block.  */
2697   if (setjmp_longjmp)
2698     {
2699       tree *gnu_else_ptr = 0;
2700       tree gnu_handler;
2701
2702       /* Make a binding level for the exception handling declarations and code
2703          and set up gnu_except_ptr_stack for the handlers to use.  */
2704       start_stmt_group ();
2705       gnat_pushlevel ();
2706
2707       push_stack (&gnu_except_ptr_stack, NULL_TREE,
2708                   create_var_decl (get_identifier ("EXCEPT_PTR"),
2709                                    NULL_TREE,
2710                                    build_pointer_type (except_type_node),
2711                                    build_call_0_expr (get_excptr_decl), false,
2712                                    false, false, false, NULL, gnat_node));
2713
2714       /* Generate code for each handler. The N_Exception_Handler case does the
2715          real work and returns a COND_EXPR for each handler, which we chain
2716          together here.  */
2717       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2718            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
2719         {
2720           gnu_expr = gnat_to_gnu (gnat_temp);
2721
2722           /* If this is the first one, set it as the outer one. Otherwise,
2723              point the "else" part of the previous handler to us. Then point
2724              to our "else" part.  */
2725           if (!gnu_else_ptr)
2726             add_stmt (gnu_expr);
2727           else
2728             *gnu_else_ptr = gnu_expr;
2729
2730           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
2731         }
2732
2733       /* If none of the exception handlers did anything, re-raise but do not
2734          defer abortion.  */
2735       gnu_expr = build_call_1_expr (raise_nodefer_decl,
2736                                     TREE_VALUE (gnu_except_ptr_stack));
2737       set_expr_location_from_node (gnu_expr, gnat_node);
2738
2739       if (gnu_else_ptr)
2740         *gnu_else_ptr = gnu_expr;
2741       else
2742         add_stmt (gnu_expr);
2743
2744       /* End the binding level dedicated to the exception handlers and get the
2745          whole statement group.  */
2746       pop_stack (&gnu_except_ptr_stack);
2747       gnat_poplevel ();
2748       gnu_handler = end_stmt_group ();
2749
2750       /* If the setjmp returns 1, we restore our incoming longjmp value and
2751          then check the handlers.  */
2752       start_stmt_group ();
2753       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
2754                                              gnu_jmpsave_decl),
2755                           gnat_node);
2756       add_stmt (gnu_handler);
2757       gnu_handler = end_stmt_group ();
2758
2759       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
2760       gnu_result = build3 (COND_EXPR, void_type_node,
2761                            (build_call_1_expr
2762                             (setjmp_decl,
2763                              build_unary_op (ADDR_EXPR, NULL_TREE,
2764                                              gnu_jmpbuf_decl))),
2765                            gnu_handler, gnu_inner_block);
2766     }
2767   else if (gcc_zcx)
2768     {
2769       tree gnu_handlers;
2770
2771       /* First make a block containing the handlers.  */
2772       start_stmt_group ();
2773       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2774            Present (gnat_temp);
2775            gnat_temp = Next_Non_Pragma (gnat_temp))
2776         add_stmt (gnat_to_gnu (gnat_temp));
2777       gnu_handlers = end_stmt_group ();
2778
2779       /* Now make the TRY_CATCH_EXPR for the block.  */
2780       gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
2781                            gnu_inner_block, gnu_handlers);
2782     }
2783   else
2784     gnu_result = gnu_inner_block;
2785
2786   /* Now close our outer block, if we had to make one.  */
2787   if (binding_for_block)
2788     {
2789       add_stmt (gnu_result);
2790       gnat_poplevel ();
2791       gnu_result = end_stmt_group ();
2792     }
2793
2794   return gnu_result;
2795 }
2796 \f
2797 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2798    to a GCC tree, which is returned.  This is the variant for Setjmp_Longjmp
2799    exception handling.  */
2800
2801 static tree
2802 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
2803 {
2804   /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
2805      an "if" statement to select the proper exceptions.  For "Others", exclude
2806      exceptions where Handled_By_Others is nonzero unless the All_Others flag
2807      is set. For "Non-ada", accept an exception if "Lang" is 'V'.  */
2808   tree gnu_choice = integer_zero_node;
2809   tree gnu_body = build_stmt_group (Statements (gnat_node), false);
2810   Node_Id gnat_temp;
2811
2812   for (gnat_temp = First (Exception_Choices (gnat_node));
2813        gnat_temp; gnat_temp = Next (gnat_temp))
2814     {
2815       tree this_choice;
2816
2817       if (Nkind (gnat_temp) == N_Others_Choice)
2818         {
2819           if (All_Others (gnat_temp))
2820             this_choice = integer_one_node;
2821           else
2822             this_choice
2823               = build_binary_op
2824                 (EQ_EXPR, integer_type_node,
2825                  convert
2826                  (integer_type_node,
2827                   build_component_ref
2828                   (build_unary_op
2829                    (INDIRECT_REF, NULL_TREE,
2830                     TREE_VALUE (gnu_except_ptr_stack)),
2831                    get_identifier ("not_handled_by_others"), NULL_TREE,
2832                    false)),
2833                  integer_zero_node);
2834         }
2835
2836       else if (Nkind (gnat_temp) == N_Identifier
2837                || Nkind (gnat_temp) == N_Expanded_Name)
2838         {
2839           Entity_Id gnat_ex_id = Entity (gnat_temp);
2840           tree gnu_expr;
2841
2842           /* Exception may be a renaming. Recover original exception which is
2843              the one elaborated and registered.  */
2844           if (Present (Renamed_Object (gnat_ex_id)))
2845             gnat_ex_id = Renamed_Object (gnat_ex_id);
2846
2847           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2848
2849           this_choice
2850             = build_binary_op
2851               (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack),
2852                convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
2853                         build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
2854
2855           /* If this is the distinguished exception "Non_Ada_Error" (and we are
2856              in VMS mode), also allow a non-Ada exception (a VMS condition) t
2857              match.  */
2858           if (Is_Non_Ada_Error (Entity (gnat_temp)))
2859             {
2860               tree gnu_comp
2861                 = build_component_ref
2862                   (build_unary_op (INDIRECT_REF, NULL_TREE,
2863                                    TREE_VALUE (gnu_except_ptr_stack)),
2864                    get_identifier ("lang"), NULL_TREE, false);
2865
2866               this_choice
2867                 = build_binary_op
2868                   (TRUTH_ORIF_EXPR, integer_type_node,
2869                    build_binary_op (EQ_EXPR, integer_type_node, gnu_comp,
2870                                     build_int_cst (TREE_TYPE (gnu_comp), 'V')),
2871                    this_choice);
2872             }
2873         }
2874       else
2875         gcc_unreachable ();
2876
2877       gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
2878                                     gnu_choice, this_choice);
2879     }
2880
2881   return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
2882 }
2883 \f
2884 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2885    to a GCC tree, which is returned.  This is the variant for ZCX.  */
2886
2887 static tree
2888 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
2889 {
2890   tree gnu_etypes_list = NULL_TREE;
2891   tree gnu_expr;
2892   tree gnu_etype;
2893   tree gnu_current_exc_ptr;
2894   tree gnu_incoming_exc_ptr;
2895   Node_Id gnat_temp;
2896
2897   /* We build a TREE_LIST of nodes representing what exception types this
2898      handler can catch, with special cases for others and all others cases.
2899
2900      Each exception type is actually identified by a pointer to the exception
2901      id, or to a dummy object for "others" and "all others".
2902
2903      Care should be taken to ensure that the control flow impact of "others"
2904      and "all others" is known to GCC. lang_eh_type_covers is doing the trick
2905      currently.  */
2906   for (gnat_temp = First (Exception_Choices (gnat_node));
2907        gnat_temp; gnat_temp = Next (gnat_temp))
2908     {
2909       if (Nkind (gnat_temp) == N_Others_Choice)
2910         {
2911           tree gnu_expr
2912             = All_Others (gnat_temp) ? all_others_decl : others_decl;
2913
2914           gnu_etype
2915             = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2916         }
2917       else if (Nkind (gnat_temp) == N_Identifier
2918                || Nkind (gnat_temp) == N_Expanded_Name)
2919         {
2920           Entity_Id gnat_ex_id = Entity (gnat_temp);
2921
2922           /* Exception may be a renaming. Recover original exception which is
2923              the one elaborated and registered.  */
2924           if (Present (Renamed_Object (gnat_ex_id)))
2925             gnat_ex_id = Renamed_Object (gnat_ex_id);
2926
2927           gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2928           gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2929
2930           /* The Non_Ada_Error case for VMS exceptions is handled
2931              by the personality routine.  */
2932         }
2933       else
2934         gcc_unreachable ();
2935
2936       /* The GCC interface expects NULL to be passed for catch all handlers, so
2937          it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
2938          is integer_zero_node.  It would not work, however, because GCC's
2939          notion of "catch all" is stronger than our notion of "others".  Until
2940          we correctly use the cleanup interface as well, doing that would
2941          prevent the "all others" handlers from being seen, because nothing
2942          can be caught beyond a catch all from GCC's point of view.  */
2943       gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
2944     }
2945
2946   start_stmt_group ();
2947   gnat_pushlevel ();
2948
2949   /* Expand a call to the begin_handler hook at the beginning of the handler,
2950      and arrange for a call to the end_handler hook to occur on every possible
2951      exit path.
2952
2953      The hooks expect a pointer to the low level occurrence. This is required
2954      for our stack management scheme because a raise inside the handler pushes
2955      a new occurrence on top of the stack, which means that this top does not
2956      necessarily match the occurrence this handler was dealing with.
2957
2958      The EXC_PTR_EXPR object references the exception occurrence being
2959      propagated. Upon handler entry, this is the exception for which the
2960      handler is triggered. This might not be the case upon handler exit,
2961      however, as we might have a new occurrence propagated by the handler's
2962      body, and the end_handler hook called as a cleanup in this context.
2963
2964      We use a local variable to retrieve the incoming value at handler entry
2965      time, and reuse it to feed the end_handler hook's argument at exit.  */
2966   gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
2967   gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
2968                                           ptr_type_node, gnu_current_exc_ptr,
2969                                           false, false, false, false, NULL,
2970                                           gnat_node);
2971
2972   add_stmt_with_node (build_call_1_expr (begin_handler_decl,
2973                                          gnu_incoming_exc_ptr),
2974                       gnat_node);
2975   /* ??? We don't seem to have an End_Label at hand to set the location.  */
2976   add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
2977                Empty);
2978   add_stmt_list (Statements (gnat_node));
2979   gnat_poplevel ();
2980
2981   return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
2982                  end_stmt_group ());
2983 }
2984 \f
2985 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
2986
2987 static void
2988 Compilation_Unit_to_gnu (Node_Id gnat_node)
2989 {
2990   /* Make the decl for the elaboration procedure.  */
2991   bool body_p = (Defining_Entity (Unit (gnat_node)),
2992             Nkind (Unit (gnat_node)) == N_Package_Body
2993             || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
2994   Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
2995   tree gnu_elab_proc_decl
2996     = create_subprog_decl
2997       (create_concat_name (gnat_unit_entity,
2998                            body_p ? "elabb" : "elabs"),
2999        NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
3000        gnat_unit_entity);
3001   struct elab_info *info;
3002
3003   push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
3004
3005   DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
3006   allocate_struct_function (gnu_elab_proc_decl, false);
3007   Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
3008   set_cfun (NULL);
3009
3010   /* For a body, first process the spec if there is one. */
3011   if (Nkind (Unit (gnat_node)) == N_Package_Body
3012       || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3013               && !Acts_As_Spec (gnat_node)))
3014     {
3015       add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
3016       finalize_from_with_types ();
3017     }
3018
3019   process_inlined_subprograms (gnat_node);
3020
3021   if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3022     {
3023       elaborate_all_entities (gnat_node);
3024
3025       if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
3026           || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
3027           || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
3028         return;
3029     }
3030
3031   process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
3032                  true, true);
3033   add_stmt (gnat_to_gnu (Unit (gnat_node)));
3034
3035   /* Process any pragmas and actions following the unit.  */
3036   add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
3037   add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
3038   finalize_from_with_types ();
3039
3040   /* Save away what we've made so far and record this potential elaboration
3041      procedure.  */
3042   info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
3043   set_current_block_context (gnu_elab_proc_decl);
3044   gnat_poplevel ();
3045   DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
3046   info->next = elab_info_list;
3047   info->elab_proc = gnu_elab_proc_decl;
3048   info->gnat_node = gnat_node;
3049   elab_info_list = info;
3050
3051   /* Generate elaboration code for this unit, if necessary, and say whether
3052      we did or not.  */
3053   pop_stack (&gnu_elab_proc_stack);
3054
3055   /* Invalidate the global renaming pointers.  This is necessary because
3056      stabilization of the renamed entities may create SAVE_EXPRs which
3057      have been tied to a specific elaboration routine just above.  */
3058   invalidate_global_renaming_pointers ();
3059 }
3060 \f
3061 /* This function is the driver of the GNAT to GCC tree transformation
3062    process.  It is the entry point of the tree transformer.  GNAT_NODE is the
3063    root of some GNAT tree.  Return the root of the corresponding GCC tree.
3064    If this is an expression, return the GCC equivalent of the expression.  If
3065    it is a statement, return the statement.  In the case when called for a
3066    statement, it may also add statements to the current statement group, in
3067    which case anything it returns is to be interpreted as occurring after
3068    anything `it already added.  */
3069
3070 tree
3071 gnat_to_gnu (Node_Id gnat_node)
3072 {
3073   bool went_into_elab_proc = false;
3074   tree gnu_result = error_mark_node; /* Default to no value. */
3075   tree gnu_result_type = void_type_node;
3076   tree gnu_expr;
3077   tree gnu_lhs, gnu_rhs;
3078   Node_Id gnat_temp;
3079
3080   /* Save node number for error message and set location information.  */
3081   error_gnat_node = gnat_node;
3082   Sloc_to_locus (Sloc (gnat_node), &input_location);
3083
3084   if (type_annotate_only
3085       && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call))
3086     return alloc_stmt_list ();
3087
3088   /* If this node is a non-static subexpression and we are only
3089      annotating types, make this into a NULL_EXPR.  */
3090   if (type_annotate_only
3091       && IN (Nkind (gnat_node), N_Subexpr)
3092       && Nkind (gnat_node) != N_Identifier
3093       && !Compile_Time_Known_Value (gnat_node))
3094     return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
3095                    build_call_raise (CE_Range_Check_Failed, gnat_node,
3096                                      N_Raise_Constraint_Error));
3097
3098   /* If this is a Statement and we are at top level, it must be part of the
3099      elaboration procedure, so mark us as being in that procedure and push our
3100      context.
3101
3102      If we are in the elaboration procedure, check if we are violating a a
3103      No_Elaboration_Code restriction by having a statement there.  */
3104   if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
3105        && Nkind (gnat_node) != N_Null_Statement)
3106       || Nkind (gnat_node) == N_Procedure_Call_Statement
3107       || Nkind (gnat_node) == N_Label
3108       || Nkind (gnat_node) == N_Implicit_Label_Declaration
3109       || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
3110       || ((Nkind (gnat_node) == N_Raise_Constraint_Error
3111            || Nkind (gnat_node) == N_Raise_Storage_Error
3112            || Nkind (gnat_node) == N_Raise_Program_Error)
3113           && (Ekind (Etype (gnat_node)) == E_Void)))
3114     {
3115       if (!current_function_decl)
3116         {
3117           current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
3118           start_stmt_group ();
3119           gnat_pushlevel ();
3120           went_into_elab_proc = true;
3121         }
3122
3123       /* Don't check for a possible No_Elaboration_Code restriction violation
3124          on N_Handled_Sequence_Of_Statements, as we want to signal an error on
3125          every nested real statement instead.  This also avoids triggering
3126          spurious errors on dummy (empty) sequences created by the front-end
3127          for package bodies in some cases.  */
3128
3129       if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
3130           && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
3131         Check_Elaboration_Code_Allowed (gnat_node);
3132     }
3133
3134   switch (Nkind (gnat_node))
3135     {
3136       /********************************/
3137       /* Chapter 2: Lexical Elements: */
3138       /********************************/
3139
3140     case N_Identifier:
3141     case N_Expanded_Name:
3142     case N_Operator_Symbol:
3143     case N_Defining_Identifier:
3144       gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
3145       break;
3146
3147     case N_Integer_Literal:
3148       {
3149         tree gnu_type;
3150
3151         /* Get the type of the result, looking inside any padding and
3152            justified modular types.  Then get the value in that type.  */
3153         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3154
3155         if (TREE_CODE (gnu_type) == RECORD_TYPE
3156             && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
3157           gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3158
3159         gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
3160
3161         /* If the result overflows (meaning it doesn't fit in its base type),
3162            abort.  We would like to check that the value is within the range
3163            of the subtype, but that causes problems with subtypes whose usage
3164            will raise Constraint_Error and with biased representation, so
3165            we don't.  */
3166         gcc_assert (!TREE_OVERFLOW (gnu_result));
3167       }
3168       break;
3169
3170     case N_Character_Literal:
3171       /* If a Entity is present, it means that this was one of the
3172          literals in a user-defined character type.  In that case,
3173          just return the value in the CONST_DECL.  Otherwise, use the
3174          character code.  In that case, the base type should be an
3175          INTEGER_TYPE, but we won't bother checking for that.  */
3176       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3177       if (Present (Entity (gnat_node)))
3178         gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
3179       else
3180         gnu_result
3181           = build_int_cst_type
3182               (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
3183       break;
3184
3185     case N_Real_Literal:
3186       /* If this is of a fixed-point type, the value we want is the
3187          value of the corresponding integer.  */
3188       if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
3189         {
3190           gnu_result_type = get_unpadded_type (Etype (gnat_node));
3191           gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
3192                                   gnu_result_type);
3193           gcc_assert (!TREE_OVERFLOW (gnu_result));
3194         }
3195
3196       /* We should never see a Vax_Float type literal, since the front end
3197          is supposed to transform these using appropriate conversions */
3198       else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
3199         gcc_unreachable ();
3200
3201       else
3202         {
3203           Ureal ur_realval = Realval (gnat_node);
3204
3205           gnu_result_type = get_unpadded_type (Etype (gnat_node));
3206
3207           /* If the real value is zero, so is the result.  Otherwise,
3208              convert it to a machine number if it isn't already.  That
3209              forces BASE to 0 or 2 and simplifies the rest of our logic.  */
3210           if (UR_Is_Zero (ur_realval))
3211             gnu_result = convert (gnu_result_type, integer_zero_node);
3212           else
3213             {
3214               if (!Is_Machine_Number (gnat_node))
3215                 ur_realval
3216                   = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
3217                              ur_realval, Round_Even, gnat_node);
3218
3219               gnu_result
3220                 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
3221
3222               /* If we have a base of zero, divide by the denominator.
3223                  Otherwise, the base must be 2 and we scale the value, which
3224                  we know can fit in the mantissa of the type (hence the use
3225                  of that type above).  */
3226               if (No (Rbase (ur_realval)))
3227                 gnu_result
3228                   = build_binary_op (RDIV_EXPR,
3229                                      get_base_type (gnu_result_type),
3230                                      gnu_result,
3231                                      UI_To_gnu (Denominator (ur_realval),
3232                                                 gnu_result_type));
3233               else
3234                 {
3235                   REAL_VALUE_TYPE tmp;
3236
3237                   gcc_assert (Rbase (ur_realval) == 2);
3238                   real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
3239                               - UI_To_Int (Denominator (ur_realval)));
3240                   gnu_result = build_real (gnu_result_type, tmp);
3241                 }
3242             }
3243
3244           /* Now see if we need to negate the result.  Do it this way to
3245              properly handle -0.  */
3246           if (UR_Is_Negative (Realval (gnat_node)))
3247             gnu_result
3248               = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
3249