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