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