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