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