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