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