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