gcc/ada/trans.c

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