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-2003, 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               post_error_ne ("cannot call eliminated subprogram &!",
2809                              gnat_node, Entity (Name (gnat_node)));
2810           }
2811
2812         if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE)
2813           gigi_abort (317);
2814
2815         /* If we are calling a stubbed function, make this into a
2816            raise of Program_Error.  Elaborate all our args first.  */
2817
2818         if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
2819             && DECL_STUBBED_P (gnu_subprog_node))
2820           {
2821             for (gnat_actual = First_Actual (gnat_node);
2822                  Present (gnat_actual);
2823                  gnat_actual = Next_Actual (gnat_actual))
2824               expand_expr_stmt (gnat_to_gnu (gnat_actual));
2825
2826             if (Nkind (gnat_node) == N_Function_Call)
2827               {
2828                 gnu_result_type = TREE_TYPE (gnu_subprog_type);
2829                 gnu_result
2830                   = build1 (NULL_EXPR, gnu_result_type,
2831                             build_call_raise (PE_Stubbed_Subprogram_Called));
2832               }
2833             else
2834               expand_expr_stmt
2835                 (build_call_raise (PE_Stubbed_Subprogram_Called));
2836             break;
2837           }
2838
2839         /* The only way we can be making a call via an access type is
2840            if Name is an explicit dereference.  In that case, get the
2841            list of formal args from the type the access type is pointing
2842            to.  Otherwise, get the formals from entity being called.  */
2843         if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2844           gnat_formal = First_Formal (Etype (Name (gnat_node)));
2845         else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2846           /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2847           gnat_formal = 0;
2848         else
2849           gnat_formal = First_Formal (Entity (Name (gnat_node)));
2850
2851         /* Create the list of the actual parameters as GCC expects it, namely
2852            a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2853            node is a parameter-expression and the TREE_PURPOSE field is
2854            null.  Skip OUT parameters that are not passed by reference and
2855            don't need to be copied in.  */
2856
2857         for (gnat_actual = First_Actual (gnat_node);
2858              Present (gnat_actual);
2859              gnat_formal = Next_Formal_With_Extras (gnat_formal),
2860              gnat_actual = Next_Actual (gnat_actual))
2861           {
2862             tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2863             /* We treat a conversion between aggregate types as if it
2864                is an unchecked conversion.  */
2865             int unchecked_convert_p
2866               = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2867                  || (Nkind (gnat_actual) == N_Type_Conversion
2868                      && Is_Composite_Type (Underlying_Type
2869                                            (Etype (gnat_formal)))));
2870             Node_Id gnat_name
2871               = unchecked_convert_p ? Expression (gnat_actual) : gnat_actual;
2872             tree gnu_name = gnat_to_gnu (gnat_name);
2873             tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
2874             tree gnu_actual;
2875
2876             /* If it's possible we may need to use this expression twice,
2877                make sure than any side-effects are handled via SAVE_EXPRs.
2878                Likewise if we need to force side-effects before the call.
2879                ??? This is more conservative than we need since we don't
2880                need to do this for pass-by-ref with no conversion.
2881                If we are passing a non-addressable Out or In Out parameter by
2882                reference, pass the address of a copy and set up to copy back
2883                out after the call.  */
2884
2885             if (Ekind (gnat_formal) != E_In_Parameter)
2886               {
2887                 gnu_name = gnat_stabilize_reference (gnu_name, 1);
2888                 if (! addressable_p (gnu_name)
2889                     && present_gnu_tree (gnat_formal)
2890                     && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2891                         || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2892                             && (DECL_BY_COMPONENT_PTR_P
2893                                 (get_gnu_tree (gnat_formal))
2894                                 || DECL_BY_DESCRIPTOR_P
2895                                 (get_gnu_tree (gnat_formal))))))
2896                   {
2897                     tree gnu_copy = gnu_name;
2898                     tree gnu_temp;
2899
2900                     /* Remove any unpadding on the actual and make a copy.
2901                        But if the actual is a left-justified modular type,
2902                        first convert to it.  */
2903                     if (TREE_CODE (gnu_name) == COMPONENT_REF
2904                         && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
2905                              == RECORD_TYPE)
2906                             && (TYPE_IS_PADDING_P
2907                                 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
2908                       gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
2909                     else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2910                              && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2911                                  (gnu_name_type)))
2912                       gnu_name = convert (gnu_name_type, gnu_name);
2913
2914                     gnu_actual = save_expr (gnu_name);
2915
2916                     /* Since we're going to take the address of the SAVE_EXPR,
2917                        we don't want it to be marked as unchanging.
2918                        So set TREE_ADDRESSABLE.  */
2919                     gnu_temp = skip_simple_arithmetic (gnu_actual);
2920                     if (TREE_CODE (gnu_temp) == SAVE_EXPR)
2921                       {
2922                         TREE_ADDRESSABLE (gnu_temp) = 1;
2923                         TREE_READONLY (gnu_temp) = 0;
2924                       }
2925
2926                     /* Set up to move the copy back to the original.  */
2927                     gnu_after_list = tree_cons (gnu_copy, gnu_actual,
2928                                                 gnu_after_list);
2929
2930                     gnu_name = gnu_actual;
2931                   }
2932               }
2933
2934             /* If this was a procedure call, we may not have removed any
2935                padding.  So do it here for the part we will use as an
2936                input, if any.  */
2937             gnu_actual = gnu_name;
2938             if (Ekind (gnat_formal) != E_Out_Parameter
2939                 && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2940                 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2941               gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2942                                     gnu_actual);
2943
2944             if (Ekind (gnat_formal) != E_Out_Parameter
2945                 && ! unchecked_convert_p
2946                 && Do_Range_Check (gnat_actual))
2947               gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
2948
2949             /* Do any needed conversions.  We need only check for
2950                unchecked conversion since normal conversions will be handled
2951                by just converting to the formal type.  */
2952             if (unchecked_convert_p)
2953               {
2954                 gnu_actual
2955                   = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2956                                        gnu_actual,
2957                                        (Nkind (gnat_actual)
2958                                         == N_Unchecked_Type_Conversion)
2959                                        && No_Truncation (gnat_actual));
2960
2961                 /* One we've done the unchecked conversion, we still
2962                    must ensure that the object is in range of the formal's
2963                    type.  */
2964                 if (Ekind (gnat_formal) != E_Out_Parameter
2965                     && Do_Range_Check (gnat_actual))
2966                   gnu_actual = emit_range_check (gnu_actual,
2967                                                  Etype (gnat_formal));
2968               }
2969             else if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2970               /* We may have suppressed a conversion to the Etype of the
2971                  actual since the parent is a procedure call.  So add the
2972                  conversion here.  */
2973               gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2974                                     gnu_actual);
2975
2976             if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2977               gnu_actual = convert (gnu_formal_type, gnu_actual);
2978
2979             /* If we have not saved a GCC object for the formal, it means it
2980                is an OUT parameter not passed by reference and that does not
2981                need to be copied in. Otherwise, look at the PARM_DECL to see
2982                if it is passed by reference. */
2983             if (present_gnu_tree (gnat_formal)
2984                 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2985                 && DECL_BY_REF_P (get_gnu_tree (gnat_formal)))
2986               {
2987                 if (Ekind (gnat_formal) != E_In_Parameter)
2988                   {
2989                     gnu_actual = gnu_name;
2990
2991                     /* If we have a padded type, be sure we've removed the
2992                        padding.  */
2993                     if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2994                         && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
2995                         && TREE_CODE (gnu_actual) != SAVE_EXPR)
2996                       gnu_actual
2997                         = convert (get_unpadded_type (Etype (gnat_actual)),
2998                                    gnu_actual);
2999                   }
3000
3001                 /* The symmetry of the paths to the type of an entity is
3002                    broken here since arguments don't know that they will
3003                    be passed by ref. */
3004                 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3005                 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type,
3006                                              gnu_actual);
3007               }
3008             else if (present_gnu_tree (gnat_formal)
3009                      && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3010                      && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)))
3011               {
3012                 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3013                 gnu_actual = maybe_implicit_deref (gnu_actual);
3014                 gnu_actual = maybe_unconstrained_array (gnu_actual);
3015
3016                 if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
3017                     && TYPE_IS_PADDING_P (gnu_formal_type))
3018                   {
3019                     gnu_formal_type
3020                       = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
3021                     gnu_actual = convert (gnu_formal_type, gnu_actual);
3022                   }
3023
3024                 /* Take the address of the object and convert to the
3025                    proper pointer type.  We'd like to actually compute
3026                    the address of the beginning of the array using
3027                    an ADDR_EXPR of an ARRAY_REF, but there's a possibility
3028                    that the ARRAY_REF might return a constant and we'd
3029                    be getting the wrong address.  Neither approach is
3030                    exactly correct, but this is the most likely to work
3031                    in all cases.  */
3032                 gnu_actual = convert (gnu_formal_type,
3033                                       build_unary_op (ADDR_EXPR, NULL_TREE,
3034                                                       gnu_actual));
3035               }
3036             else if (present_gnu_tree (gnat_formal)
3037                      && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3038                      && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal)))
3039               {
3040                 /* If arg is 'Null_Parameter, pass zero descriptor.  */
3041                 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
3042                      || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
3043                     && TREE_PRIVATE (gnu_actual))
3044                   gnu_actual
3045                     = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
3046                                integer_zero_node);
3047                 else
3048                   gnu_actual
3049                     = build_unary_op (ADDR_EXPR, NULL_TREE,
3050                                       fill_vms_descriptor (gnu_actual,
3051                                                            gnat_formal));
3052               }
3053             else
3054               {
3055                 tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
3056
3057                 if (Ekind (gnat_formal) != E_In_Parameter)
3058                   gnu_name_list
3059                     = chainon (gnu_name_list,
3060                                build_tree_list (NULL_TREE, gnu_name));
3061
3062                 if (! present_gnu_tree (gnat_formal)
3063                     || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL)
3064                   continue;
3065
3066                 /* If this is 'Null_Parameter, pass a zero even though we are
3067                    dereferencing it.  */
3068                 else if (TREE_CODE (gnu_actual) == INDIRECT_REF
3069                          && TREE_PRIVATE (gnu_actual)
3070                          && host_integerp (gnu_actual_size, 1)
3071                          && 0 >= compare_tree_int (gnu_actual_size,
3072                                                    BITS_PER_WORD))
3073                   gnu_actual
3074                     = unchecked_convert
3075                       (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
3076                        convert (gnat_type_for_size
3077                                 (tree_low_cst (gnu_actual_size, 1), 1),
3078                                 integer_zero_node), 0);
3079                 else
3080                   gnu_actual
3081                     = convert (TYPE_MAIN_VARIANT
3082                                (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))),
3083                                gnu_actual);
3084               }
3085
3086             gnu_actual_list
3087               = chainon (gnu_actual_list,
3088                          build_tree_list (NULL_TREE, gnu_actual));
3089           }
3090
3091         gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
3092                                   gnu_subprog_addr, gnu_actual_list,
3093                                   NULL_TREE);
3094         TREE_SIDE_EFFECTS (gnu_subprog_call) = 1;
3095
3096         /* If it is a function call, the result is the call expression.  */
3097         if (Nkind (gnat_node) == N_Function_Call)
3098           {
3099             gnu_result = gnu_subprog_call;
3100
3101             /* If the function returns an unconstrained array or by reference,
3102                we have to de-dereference the pointer.  */
3103             if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
3104                 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
3105               gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
3106                                            gnu_result);
3107
3108             gnu_result_type = get_unpadded_type (Etype (gnat_node));
3109           }
3110
3111         /* If this is the case where the GNAT tree contains a procedure call
3112            but the Ada procedure has copy in copy out parameters, the special
3113            parameter passing mechanism must be used.  */
3114         else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
3115           {
3116             /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3117                in copy out parameters.  */
3118             tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3119             int length = list_length (scalar_return_list);
3120
3121             if (length > 1)
3122               {
3123                 tree gnu_name;
3124
3125                 gnu_subprog_call = protect_multiple_eval (gnu_subprog_call);
3126
3127                 /* If any of the names had side-effects, ensure they are
3128                    all evaluated before the call.  */
3129                 for (gnu_name = gnu_name_list; gnu_name;
3130                      gnu_name = TREE_CHAIN (gnu_name))
3131                   if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
3132                     gnu_subprog_call
3133                       = build (COMPOUND_EXPR, TREE_TYPE (gnu_subprog_call),
3134                                TREE_VALUE (gnu_name), gnu_subprog_call);
3135               }
3136
3137             if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3138               gnat_formal = First_Formal (Etype (Name (gnat_node)));
3139             else
3140               gnat_formal = First_Formal (Entity (Name (gnat_node)));
3141
3142             for (gnat_actual = First_Actual (gnat_node);
3143                  Present (gnat_actual);
3144                  gnat_formal = Next_Formal_With_Extras (gnat_formal),
3145                  gnat_actual = Next_Actual (gnat_actual))
3146               /* If we are dealing with a copy in copy out parameter, we must
3147                  retrieve its value from the record returned in the function
3148                  call.  */
3149               if (! (present_gnu_tree (gnat_formal)
3150                      && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3151                      && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
3152                          || ((TREE_CODE (get_gnu_tree (gnat_formal))
3153                               == PARM_DECL)
3154                              && ((DECL_BY_COMPONENT_PTR_P
3155                                   (get_gnu_tree (gnat_formal))
3156                                   || (DECL_BY_DESCRIPTOR_P
3157                                       (get_gnu_tree (gnat_formal))))))))
3158                   && Ekind (gnat_formal) != E_In_Parameter)
3159                 {
3160                   /* Get the value to assign to this OUT or IN OUT
3161                      parameter.  It is either the result of the function if
3162                      there is only a single such parameter or the appropriate
3163                      field from the record returned.  */
3164                   tree gnu_result
3165                     = length == 1 ? gnu_subprog_call
3166                       : build_component_ref
3167                         (gnu_subprog_call, NULL_TREE,
3168                          TREE_PURPOSE (scalar_return_list), 0);
3169                   int unchecked_conversion
3170                     = Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
3171                   /* If the actual is a conversion, get the inner expression,
3172                      which will be the real destination, and convert the
3173                      result to the type of the actual parameter.  */
3174                   tree gnu_actual
3175                     = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3176
3177                   /* If the result is a padded type, remove the padding.  */
3178                   if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
3179                       && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3180                     gnu_result
3181                       = convert (TREE_TYPE (TYPE_FIELDS
3182                                             (TREE_TYPE (gnu_result))),
3183                                  gnu_result);
3184
3185                   /* If the result is a type conversion, do it.  */
3186                   if (Nkind (gnat_actual) == N_Type_Conversion)
3187                     gnu_result
3188                       = convert_with_check
3189                         (Etype (Expression (gnat_actual)), gnu_result,
3190                          Do_Overflow_Check (gnat_actual),
3191                          Do_Range_Check (Expression (gnat_actual)),
3192                          Float_Truncate (gnat_actual));
3193
3194                   else if (unchecked_conversion)
3195                     gnu_result
3196                       = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result,
3197                                            No_Truncation (gnat_actual));
3198                   else
3199                     {
3200                       if (Do_Range_Check (gnat_actual))
3201                         gnu_result = emit_range_check (gnu_result,
3202                                                        Etype (gnat_actual));
3203
3204                       if (! (! TREE_CONSTANT (TYPE_SIZE
3205                                               (TREE_TYPE (gnu_actual)))
3206                              && TREE_CONSTANT (TYPE_SIZE
3207                                                (TREE_TYPE (gnu_result)))))
3208                         gnu_result = convert (TREE_TYPE (gnu_actual),
3209                                               gnu_result);
3210                     }
3211
3212                   set_lineno (gnat_node, 1);
3213                   expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
3214                                                      gnu_actual, gnu_result));
3215                   scalar_return_list = TREE_CHAIN (scalar_return_list);
3216                   gnu_name_list = TREE_CHAIN (gnu_name_list);
3217                 }
3218           }
3219         else
3220           {
3221             set_lineno (gnat_node, 1);
3222             expand_expr_stmt (gnu_subprog_call);
3223           }
3224
3225         /* Handle anything we need to assign back.  */
3226         for (gnu_expr = gnu_after_list;
3227              gnu_expr;
3228              gnu_expr = TREE_CHAIN (gnu_expr))
3229           expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
3230                                              TREE_PURPOSE (gnu_expr),
3231                                              TREE_VALUE (gnu_expr)));
3232       }
3233       break;
3234
3235     /*************************/
3236     /* Chapter 7: Packages:  */
3237     /*************************/
3238
3239     case N_Package_Declaration:
3240       gnat_to_code (Specification (gnat_node));
3241       break;
3242
3243     case N_Package_Specification:
3244
3245       process_decls (Visible_Declarations (gnat_node),
3246                      Private_Declarations (gnat_node), Empty, 1, 1);
3247       break;
3248
3249     case N_Package_Body:
3250
3251       /* If this is the body of a generic package - do nothing */
3252       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
3253         break;
3254
3255       process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
3256
3257       if (Present (Handled_Statement_Sequence (gnat_node)))
3258         {
3259           gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
3260           gnat_to_code (Handled_Statement_Sequence (gnat_node));
3261           gnu_block_stack = TREE_CHAIN (gnu_block_stack);
3262         }
3263       break;
3264
3265     /*********************************/
3266     /* Chapter 8: Visibility Rules:  */
3267     /*********************************/
3268
3269     case N_Use_Package_Clause:
3270     case N_Use_Type_Clause:
3271       /* Nothing to do here - but these may appear in list of declarations */
3272       break;
3273
3274     /***********************/
3275     /* Chapter 9: Tasks:   */
3276     /***********************/
3277
3278     case N_Protected_Type_Declaration:
3279       break;
3280
3281     case N_Single_Task_Declaration:
3282       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3283       break;
3284
3285     /***********************************************************/
3286     /* Chapter 10: Program Structure and Compilation Issues:   */
3287     /***********************************************************/
3288
3289     case N_Compilation_Unit:
3290
3291       /* For a body, first process the spec if there is one. */
3292       if (Nkind (Unit (gnat_node)) == N_Package_Body
3293           || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3294               && ! Acts_As_Spec (gnat_node)))
3295         gnat_to_code (Library_Unit (gnat_node));
3296
3297       process_inlined_subprograms (gnat_node);
3298
3299       if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3300         {
3301           elaborate_all_entities (gnat_node);
3302
3303           if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
3304               || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
3305               || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
3306             break;
3307         };
3308
3309       process_decls (Declarations (Aux_Decls_Node (gnat_node)),
3310                      Empty, Empty, 1, 1);
3311
3312       gnat_to_code (Unit (gnat_node));
3313
3314       /* Process any pragmas following the unit.  */
3315       if (Present (Pragmas_After (Aux_Decls_Node (gnat_node))))
3316         for (gnat_temp = First (Pragmas_After (Aux_Decls_Node (gnat_node)));
3317              gnat_temp; gnat_temp = Next (gnat_temp))
3318           gnat_to_code (gnat_temp);
3319
3320       /* Put all the Actions into the elaboration routine if we already had
3321          elaborations.  This will happen anyway if they are statements, but we
3322          want to force declarations there too due to order-of-elaboration
3323          issues.  Most should have Is_Statically_Allocated set.  If we
3324          have had no elaborations, we have no order-of-elaboration issue and
3325          don't want to create elaborations here.  */
3326       if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node))))
3327         for (gnat_temp = First (Actions (Aux_Decls_Node (gnat_node)));
3328              Present (gnat_temp); gnat_temp = Next (gnat_temp))
3329           {
3330             if (pending_elaborations_p ())
3331               add_pending_elaborations (NULL_TREE,
3332                                         make_transform_expr (gnat_temp));
3333             else
3334               gnat_to_code (gnat_temp);
3335           }
3336
3337       /* Generate elaboration code for this unit, if necessary, and
3338          say whether we did or not.  */
3339       Set_Has_No_Elaboration_Code
3340         (gnat_node,
3341          build_unit_elab
3342          (Defining_Entity (Unit (gnat_node)),
3343           Nkind (Unit (gnat_node)) == N_Package_Body
3344           || Nkind (Unit (gnat_node)) == N_Subprogram_Body,
3345           get_pending_elaborations ()));
3346
3347       break;
3348
3349     case N_Subprogram_Body_Stub:
3350     case N_Package_Body_Stub:
3351     case N_Protected_Body_Stub:
3352     case N_Task_Body_Stub:
3353       /* Simply process whatever unit is being inserted.  */
3354       gnat_to_code (Unit (Library_Unit (gnat_node)));
3355       break;
3356
3357     case N_Subunit:
3358       gnat_to_code (Proper_Body (gnat_node));
3359       break;
3360
3361     /***************************/
3362     /* Chapter 11: Exceptions: */
3363     /***************************/
3364
3365     case N_Handled_Sequence_Of_Statements:
3366
3367       /* The GCC exception handling mechanism can handle both ZCX and SJLJ
3368          schemes and we have our own SJLJ mechanism. To call the GCC
3369          mechanism, we first call expand_eh_region_start if there is at least
3370          one handler associated with the region.  We then generate code for
3371          the region and call expand_start_all_catch to announce that the
3372          associated handlers are going to be generated.
3373
3374          For each handler we call expand_start_catch, generate code for the
3375          handler, and then call expand_end_catch.
3376
3377          After all the handlers, we call expand_end_all_catch.
3378
3379          Here we deal with the region level calls and the
3380          N_Exception_Handler branch deals with the handler level calls
3381          (start_catch/end_catch).
3382
3383          ??? The region level calls down there have been specifically put in
3384          place for a ZCX context and currently the order in which things are
3385          emitted (region/handlers) is different from the SJLJ case. Instead of
3386          putting other calls with different conditions at other places for the
3387          SJLJ case, it seems cleaner to reorder things for the SJLJ case and
3388          generalize the condition to make it not ZCX specific. */
3389
3390       /* If there is an At_End procedure attached to this node, and the eh
3391          mechanism is GNAT oriented (SJLJ or ZCX with front end tables), we
3392          must have at least a corresponding At_End handler, unless the
3393          No_Exception_Handlers restriction is set.  */
3394       if (! type_annotate_only
3395           && Exception_Mechanism != GCC_ZCX
3396           && Present (At_End_Proc (gnat_node))
3397           && ! Present (Exception_Handlers (gnat_node))
3398           && ! No_Exception_Handlers_Set())
3399         gigi_abort (335);
3400
3401       {
3402         /* Need a binding level that we can exit for this sequence if there is
3403            at least one exception handler for this block (since each handler
3404            needs an identified exit point) or there is an At_End procedure
3405            attached to this node (in order to have an attachment point for a
3406            GCC cleanup).  */
3407         bool exitable_binding_for_block
3408           = (! type_annotate_only
3409              && (Present (Exception_Handlers (gnat_node))
3410                  || Present (At_End_Proc (gnat_node))));
3411
3412         /* Make a binding level that we can exit if we need one.  */
3413         if (exitable_binding_for_block)
3414           {
3415             pushlevel (0);
3416             expand_start_bindings (1);
3417           }
3418
3419         /* If we are to call a function when exiting this block, expand a GCC
3420            cleanup to take care. We have made a binding level for this cleanup
3421            above.  */
3422         if (Present (At_End_Proc (gnat_node)))
3423           {
3424             tree gnu_cleanup_call
3425               = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
3426
3427             tree gnu_cleanup_decl
3428               = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
3429                                  integer_type_node, NULL_TREE, 0, 0, 0, 0,
3430                                  0);
3431
3432             expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
3433           }
3434
3435         /* Now we generate the code for this block, with a different layout
3436            for GNAT SJLJ and for GCC or front end ZCX. The handlers come first
3437            in the GNAT SJLJ case, while they come after the handled sequence
3438            in the other cases.  */
3439
3440         /* First deal with possible handlers for the GNAT SJLJ scheme.  */
3441         if (! type_annotate_only
3442             && Exception_Mechanism == Setjmp_Longjmp
3443             && Present (Exception_Handlers (gnat_node)))
3444           {
3445             /* We already have a fresh binding level at hand. Declare a
3446                variable to save the old __gnat_jmpbuf value and a variable for
3447                our jmpbuf.  Call setjmp and handle each of the possible
3448                exceptions if it returns one. */
3449
3450             tree gnu_jmpsave_decl
3451               = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
3452                                  jmpbuf_ptr_type,
3453                                  build_call_0_expr (get_jmpbuf_decl),
3454                                  0, 0, 0, 0, 0);
3455
3456             tree gnu_jmpbuf_decl
3457               = create_var_decl (get_identifier ("JMP_BUF"),
3458                                  NULL_TREE, jmpbuf_type,
3459                                  NULL_TREE, 0, 0, 0, 0,
3460                                  0);
3461
3462             TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
3463
3464             /* When we exit this block, restore the saved value.  */
3465             expand_decl_cleanup (gnu_jmpsave_decl,
3466                                  build_call_1_expr (set_jmpbuf_decl,
3467                                                     gnu_jmpsave_decl));
3468
3469             /* Call setjmp and handle exceptions if it returns one.  */
3470             set_lineno (gnat_node, 1);
3471             expand_start_cond
3472               (build_call_1_expr (setjmp_decl,
3473                                   build_unary_op (ADDR_EXPR, NULL_TREE,
3474                                                   gnu_jmpbuf_decl)),
3475                0);
3476
3477             /* Restore our incoming longjmp value before we do anything.  */
3478             expand_expr_stmt
3479               (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
3480
3481             /* Make a binding level for the exception handling declarations
3482                and code. Don't assign it an exit label, since this is the
3483                outer block we want to exit at the end of each handler.  */
3484             pushlevel (0);
3485             expand_start_bindings (0);
3486
3487             gnu_except_ptr_stack
3488               = tree_cons (NULL_TREE,
3489                            create_var_decl
3490                            (get_identifier ("EXCEPT_PTR"), NULL_TREE,
3491                             build_pointer_type (except_type_node),
3492                             build_call_0_expr (get_excptr_decl),
3493                             0, 0, 0, 0, 0),
3494                            gnu_except_ptr_stack);
3495
3496             /* Generate code for each handler. The N_Exception_Handler case
3497                below does the real work. We ignore the dummy exception handler
3498                for the identifier case, as this is used only by the front
3499                end.  */
3500             for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3501                  Present (gnat_temp);
3502                  gnat_temp = Next_Non_Pragma (gnat_temp))
3503               gnat_to_code (gnat_temp);
3504
3505             /* If none of the exception handlers did anything, re-raise
3506                but do not defer abortion.  */
3507             set_lineno (gnat_node, 1);
3508             expand_expr_stmt
3509               (build_call_1_expr (raise_nodefer_decl,
3510                                   TREE_VALUE (gnu_except_ptr_stack)));
3511
3512             gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
3513
3514             /* End the binding level dedicated to the exception handlers.  */
3515             expand_end_bindings (getdecls (), kept_level_p (), -1);
3516             poplevel (kept_level_p (), 1, 0);
3517
3518             /* End the "if" on setjmp.  Note that we have arranged things so
3519                control never returns here.  */
3520             expand_end_cond ();
3521
3522             /* This is now immediately before the body proper. Set our jmp_buf
3523                as the current buffer.  */
3524             expand_expr_stmt
3525               (build_call_1_expr (set_jmpbuf_decl,
3526                                   build_unary_op (ADDR_EXPR, NULL_TREE,
3527                                                   gnu_jmpbuf_decl)));
3528           }
3529
3530         /* Now comes the processing for the sequence body.  */
3531
3532         /* If we use the back-end eh support, tell the back-end we are
3533            starting a new exception region.  */
3534         if (! type_annotate_only
3535             && Exception_Mechanism == GCC_ZCX
3536             && Present (Exception_Handlers (gnat_node)))
3537           expand_eh_region_start ();
3538
3539         /* Generate code and declarations for the prefix of this block,
3540            if any.  */
3541         if (Present (First_Real_Statement (gnat_node)))
3542           process_decls (Statements (gnat_node), Empty,
3543                          First_Real_Statement (gnat_node), 1, 1);
3544
3545         /* Generate code for each statement in the block.  */
3546         for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3547                           ? First_Real_Statement (gnat_node)
3548                           : First (Statements (gnat_node)));
3549              Present (gnat_temp);
3550              gnat_temp = Next (gnat_temp))
3551           gnat_to_code (gnat_temp);
3552
3553         /* Exit the binding level we made, if any.  */
3554         if (exitable_binding_for_block)
3555           expand_exit_something ();
3556
3557         /* Compile the handlers for front end ZCX or back-end supported
3558            exceptions.  */
3559         if (! type_annotate_only
3560             && Exception_Mechanism != Setjmp_Longjmp
3561             && Present (Exception_Handlers (gnat_node)))
3562           {
3563             if (Exception_Mechanism == GCC_ZCX)
3564               expand_start_all_catch ();
3565
3566             for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3567                  Present (gnat_temp);
3568                  gnat_temp = Next_Non_Pragma (gnat_temp))
3569               gnat_to_code (gnat_temp);
3570
3571             if (Exception_Mechanism == GCC_ZCX)
3572               expand_end_all_catch ();
3573           }
3574
3575         /* Close the binding level we made, if any.  */
3576         if (exitable_binding_for_block)
3577           {
3578             expand_end_bindings (getdecls (), kept_level_p (), -1);
3579             poplevel (kept_level_p (), 1, 0);
3580           }
3581       }
3582
3583       break;
3584
3585     case N_Exception_Handler:
3586       if (Exception_Mechanism == Setjmp_Longjmp)
3587         {
3588           /* Unless this is "Others" or the special "Non-Ada" exception
3589              for Ada, make an "if" statement to select the proper
3590              exceptions.  For "Others", exclude exceptions where
3591              Handled_By_Others is nonzero unless the All_Others flag is set.
3592              For "Non-ada", accept an exception if "Lang" is 'V'.  */
3593           tree gnu_choice = integer_zero_node;
3594
3595           for (gnat_temp = First (Exception_Choices (gnat_node));
3596                gnat_temp; gnat_temp = Next (gnat_temp))
3597             {
3598               tree this_choice;
3599
3600               if (Nkind (gnat_temp) == N_Others_Choice)
3601                 {
3602                   if (All_Others (gnat_temp))
3603                     this_choice = integer_one_node;
3604                   else
3605                     this_choice
3606                       = build_binary_op
3607                         (EQ_EXPR, integer_type_node,
3608                        convert
3609                        (integer_type_node,
3610                         build_component_ref
3611                         (build_unary_op
3612                          (INDIRECT_REF, NULL_TREE,
3613                           TREE_VALUE (gnu_except_ptr_stack)),
3614                          get_identifier ("not_handled_by_others"), NULL_TREE,
3615                          0)),
3616                          integer_zero_node);
3617                 }
3618
3619               else if (Nkind (gnat_temp) == N_Identifier
3620                        || Nkind (gnat_temp) == N_Expanded_Name)
3621                 {
3622                   Entity_Id gnat_ex_id = Entity (gnat_temp);
3623
3624                   /* Exception may be a renaming. Recover original exception
3625                      which is the one elaborated and registered.  */
3626                   if (Present (Renamed_Object (gnat_ex_id)))
3627                     gnat_ex_id = Renamed_Object (gnat_ex_id);
3628
3629                   /* ??? Note that we have to use gnat_to_gnu_entity here
3630                      since the type of the exception will be wrong in the
3631                      VMS case and that's exactly what this test is for.  */
3632                   gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3633
3634                   /* If this was a VMS exception, check import_code
3635                      against the value of the exception.  */
3636                   if (TREE_CODE (TREE_TYPE (gnu_expr)) == INTEGER_TYPE)
3637                     this_choice
3638                       = build_binary_op
3639                         (EQ_EXPR, integer_type_node,
3640                          build_component_ref
3641                          (build_unary_op
3642                           (INDIRECT_REF, NULL_TREE,
3643                            TREE_VALUE (gnu_except_ptr_stack)),
3644                           get_identifier ("import_code"), NULL_TREE, 0),
3645                          gnu_expr);
3646                   else
3647                     this_choice
3648                       = build_binary_op
3649                         (EQ_EXPR, integer_type_node,
3650                          TREE_VALUE (gnu_except_ptr_stack),
3651                          convert
3652                          (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
3653                           build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3654
3655                   /* If this is the distinguished exception "Non_Ada_Error"
3656                      (and we are in VMS mode), also allow a non-Ada
3657                      exception (a VMS condition) to match.  */
3658                   if (Is_Non_Ada_Error (Entity (gnat_temp)))
3659                     {
3660                       tree gnu_comp
3661                         = build_component_ref
3662                           (build_unary_op
3663                            (INDIRECT_REF, NULL_TREE,
3664                             TREE_VALUE (gnu_except_ptr_stack)),
3665                            get_identifier ("lang"), NULL_TREE, 0);
3666
3667                       this_choice
3668                         = build_binary_op
3669                         (TRUTH_ORIF_EXPR, integer_type_node,
3670                          build_binary_op
3671                          (EQ_EXPR, integer_type_node, gnu_comp,
3672                           convert (TREE_TYPE (gnu_comp),
3673                                    build_int_2 ('V', 0))),
3674                          this_choice);
3675                     }
3676                 }
3677               else
3678                 gigi_abort (318);
3679
3680               gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
3681                                             gnu_choice, this_choice);
3682             }
3683
3684           set_lineno (gnat_node, 1);
3685
3686           expand_start_cond (gnu_choice, 0);
3687         }
3688
3689       /* Tell the back end that we start an exception handler if necessary.  */
3690       if (Exception_Mechanism == GCC_ZCX)
3691         {
3692           /* We build a TREE_LIST of nodes representing what exception
3693              types this handler is able to catch, with special cases
3694              for others and all others cases.
3695
3696              Each exception type is actually identified by a pointer to the
3697              exception id, with special value zero for "others" and one for
3698              "all others". Beware that these special values are known and used
3699              by the personality routine to identify the corresponding specific
3700              kinds of handlers.
3701
3702              ??? For initial time frame reasons, the others and all_others
3703              cases have been handled using specific type trees, but this
3704              somehow hides information to the back-end, which expects NULL to
3705              be passed for catch all and end_cleanup to be used for cleanups.
3706
3707              Care should be taken to ensure that the control flow impact of
3708              such clauses is rendered in some way. lang_eh_type_covers is
3709              doing the trick currently.  */
3710
3711           tree gnu_expr, gnu_etype;
3712           tree gnu_etypes_list = NULL_TREE;
3713
3714           for (gnat_temp = First (Exception_Choices (gnat_node));
3715                gnat_temp; gnat_temp = Next (gnat_temp))
3716             {
3717               if (Nkind (gnat_temp) == N_Others_Choice)
3718                 gnu_etype
3719                   = All_Others (gnat_temp) ? integer_one_node
3720                     : integer_zero_node;
3721               else if (Nkind (gnat_temp) == N_Identifier
3722                        || Nkind (gnat_temp) == N_Expanded_Name)
3723                 {
3724                   Entity_Id gnat_ex_id = Entity (gnat_temp);
3725
3726                   /* Exception may be a renaming. Recover original exception
3727                      which is the one elaborated and registered.  */
3728                   if (Present (Renamed_Object (gnat_ex_id)))
3729                     gnat_ex_id = Renamed_Object (gnat_ex_id);
3730
3731                   gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3732
3733                   gnu_etype
3734                     = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3735                 }
3736               else
3737                 gigi_abort (337);
3738
3739               /* The GCC interface expects NULL to be passed for catch all
3740                  handlers, so it would be quite tempting to set gnu_etypes_list
3741                  to NULL if gnu_etype is integer_zero_node.  It would not work,
3742                  however, because GCC's notion of "catch all" is stronger than
3743                  our notion of "others".  Until we correctly use the cleanup
3744                  interface as well, the doing tht would prevent the "all
3745                  others" handlers from beeing seen, because nothing can be
3746                  caught beyond a catch all from GCC's point of view.  */
3747               gnu_etypes_list
3748                 = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3749
3750             }
3751
3752           expand_start_catch (gnu_etypes_list);
3753
3754           pushlevel (0);
3755           expand_start_bindings (0);
3756
3757           {
3758             /* Expand a call to the begin_handler hook at the beginning of the
3759                handler, and arrange for a call to the end_handler hook to
3760                occur on every possible exit path.
3761
3762                The hooks expect a pointer to the low level occurrence. This
3763                is required for our stack management scheme because a raise
3764                inside the handler pushes a new occurrence on top of the
3765                stack, which means that this top does not necessarily match
3766                the occurrence this handler was dealing with.
3767
3768                The EXC_PTR_EXPR object references the exception occurrence
3769                beeing propagated. Upon handler entry, this is the exception
3770                for which the handler is triggered. This might not be the case
3771                upon handler exit, however, as we might have a new occurrence
3772                propagated by the handler's body, and the end_handler hook
3773                called as a cleanup in this context.
3774
3775                We use a local variable to retrieve the incoming value at
3776                handler entry time, and reuse it to feed the end_handler
3777                hook's argument at exit time.  */
3778             tree gnu_current_exc_ptr
3779               = build (EXC_PTR_EXPR, ptr_type_node);
3780             tree gnu_incoming_exc_ptr
3781               = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3782                                  ptr_type_node, gnu_current_exc_ptr,
3783                                  0, 0, 0, 0, 0);
3784
3785             expand_expr_stmt
3786               (build_call_1_expr (begin_handler_decl, gnu_incoming_exc_ptr));
3787             expand_decl_cleanup
3788               (0, build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr));
3789           }
3790         }
3791
3792       for (gnat_temp = First (Statements (gnat_node));
3793            gnat_temp; gnat_temp = Next (gnat_temp))
3794         gnat_to_code (gnat_temp);
3795
3796       if (Exception_Mechanism == GCC_ZCX)
3797         {
3798           /* Tell the back end that we're done with the current handler.  */
3799           expand_end_bindings (getdecls (), kept_level_p (), -1);
3800           poplevel (kept_level_p (), 1, 0);
3801
3802           expand_end_catch ();
3803         }
3804       else
3805         /* At the end of the handler, exit the block. We made this block in
3806            N_Handled_Sequence_Of_Statements.  */
3807         expand_exit_something ();
3808
3809       if (Exception_Mechanism == Setjmp_Longjmp)
3810         expand_end_cond ();
3811
3812       break;
3813
3814     /*******************************/
3815     /* Chapter 12: Generic Units:  */
3816     /*******************************/
3817
3818     case N_Generic_Function_Renaming_Declaration:
3819     case N_Generic_Package_Renaming_Declaration:
3820     case N_Generic_Procedure_Renaming_Declaration:
3821     case N_Generic_Package_Declaration:
3822     case N_Generic_Subprogram_Declaration:
3823     case N_Package_Instantiation:
3824     case N_Procedure_Instantiation:
3825     case N_Function_Instantiation:
3826       /* These nodes can appear on a declaration list but there is nothing to
3827          to be done with them.  */
3828       break;
3829
3830     /***************************************************/
3831     /* Chapter 13: Representation Clauses and          */
3832     /*             Implementation-Dependent Features:  */
3833     /***************************************************/
3834
3835     case N_Attribute_Definition_Clause:
3836
3837       /* The only one we need deal with is for 'Address.  For the others, SEM
3838          puts the information elsewhere.  We need only deal with 'Address
3839          if the object has a Freeze_Node (which it never will currently).  */
3840       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
3841           || No (Freeze_Node (Entity (Name (gnat_node)))))
3842         break;
3843
3844       /* Get the value to use as the address and save it as the
3845          equivalent for GNAT_TEMP.  When the object is frozen,
3846          gnat_to_gnu_entity will do the right thing. */
3847       gnu_expr = gnat_to_gnu (Expression (gnat_node));
3848       save_gnu_tree (Entity (Name (gnat_node)), gnu_expr, 1);
3849       break;
3850
3851     case N_Enumeration_Representation_Clause:
3852     case N_Record_Representation_Clause:
3853     case N_At_Clause:
3854       /* We do nothing with these.  SEM puts the information elsewhere.  */
3855       break;
3856
3857     case N_Code_Statement:
3858       if (! type_annotate_only)
3859         {
3860           tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
3861           tree gnu_input_list = 0, gnu_output_list = 0, gnu_orig_out_list = 0;
3862           tree gnu_clobber_list = 0;
3863           char *clobber;
3864
3865           /* First process inputs, then outputs, then clobbers.  */
3866           Setup_Asm_Inputs (gnat_node);
3867           while (Present (gnat_temp = Asm_Input_Value ()))
3868             {
3869               tree gnu_value = gnat_to_gnu (gnat_temp);
3870               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3871                                                  (Asm_Input_Constraint ()));
3872
3873               gnu_input_list
3874                 = tree_cons (gnu_constr, gnu_value, gnu_input_list);
3875               Next_Asm_Input ();
3876             }
3877
3878           Setup_Asm_Outputs (gnat_node);
3879           while (Present (gnat_temp = Asm_Output_Variable ()))
3880             {
3881               tree gnu_value = gnat_to_gnu (gnat_temp);
3882               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3883                                                  (Asm_Output_Constraint ()));
3884
3885               gnu_orig_out_list
3886                 = tree_cons (gnu_constr, gnu_value, gnu_orig_out_list);
3887               gnu_output_list
3888                 = tree_cons (gnu_constr, gnu_value, gnu_output_list);
3889               Next_Asm_Output ();
3890             }
3891
3892           Clobber_Setup (gnat_node);
3893           while ((clobber = Clobber_Get_Next ()) != 0)
3894             gnu_clobber_list
3895               = tree_cons (NULL_TREE,
3896                            build_string (strlen (clobber) + 1, clobber),
3897                            gnu_clobber_list);
3898
3899           gnu_input_list = nreverse (gnu_input_list);
3900           gnu_output_list = nreverse (gnu_output_list);
3901           gnu_orig_out_list = nreverse (gnu_orig_out_list);
3902           expand_asm_operands (gnu_template, gnu_output_list, gnu_input_list,
3903                                gnu_clobber_list, Is_Asm_Volatile (gnat_node),
3904                                input_location);
3905
3906           /* Copy all the intermediate outputs into the specified outputs.  */
3907           for (; gnu_output_list;
3908                (gnu_output_list = TREE_CHAIN (gnu_output_list),
3909                 gnu_orig_out_list = TREE_CHAIN (gnu_orig_out_list)))
3910             if (TREE_VALUE (gnu_orig_out_list) != TREE_VALUE (gnu_output_list))
3911               {
3912                 expand_expr_stmt
3913                   (build_binary_op (MODIFY_EXPR, NULL_TREE,
3914                                     TREE_VALUE (gnu_orig_out_list),
3915                                     TREE_VALUE (gnu_output_list)));
3916                 free_temp_slots ();
3917               }
3918         }
3919       break;
3920
3921     /***************************************************/
3922     /* Added Nodes                                     */
3923     /***************************************************/
3924
3925     case N_Freeze_Entity:
3926       process_freeze_entity (gnat_node);
3927       process_decls (Actions (gnat_node), Empty, Empty, 1, 1);
3928       break;
3929
3930     case N_Itype_Reference:
3931       if (! present_gnu_tree (Itype (gnat_node)))
3932         process_type (Itype (gnat_node));
3933       break;
3934
3935     case N_Free_Statement:
3936       if (! type_annotate_only)
3937         {
3938           tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
3939           tree gnu_obj_type;
3940           tree gnu_obj_size;
3941           int align;
3942
3943           /* If this is an unconstrained array, we know the object must
3944              have been allocated with the template in front of the object.
3945              So pass the template address, but get the total size.  Do this
3946              by converting to a thin pointer.  */
3947           if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
3948             gnu_ptr
3949               = convert (build_pointer_type
3950                          (TYPE_OBJECT_RECORD_TYPE
3951                           (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
3952                          gnu_ptr);
3953
3954           gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
3955           gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
3956           align = TYPE_ALIGN (gnu_obj_type);
3957
3958           if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
3959               && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
3960             {
3961               tree gnu_char_ptr_type = build_pointer_type (char_type_node);
3962               tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
3963               tree gnu_byte_offset
3964                 = convert (gnu_char_ptr_type,
3965                            size_diffop (size_zero_node, gnu_pos));
3966
3967               gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
3968               gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
3969                                          gnu_ptr, gnu_byte_offset);
3970             }
3971
3972           set_lineno (gnat_node, 1);
3973           expand_expr_stmt
3974             (build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
3975                                        Procedure_To_Call (gnat_node),
3976                                        Storage_Pool (gnat_node), gnat_node));
3977         }
3978       break;
3979
3980     case N_Raise_Constraint_Error:
3981     case N_Raise_Program_Error:
3982     case N_Raise_Storage_Error:
3983
3984       if (type_annotate_only)
3985         break;
3986
3987       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3988       gnu_result = build_call_raise (UI_To_Int (Reason (gnat_node)));
3989
3990       /* If the type is VOID, this is a statement, so we need to
3991          generate the code for the call.  Handle a Condition, if there
3992          is one.  */
3993       if (TREE_CODE (gnu_result_type) == VOID_TYPE)
3994         {
3995           set_lineno (gnat_node, 1);
3996
3997           if (Present (Condition (gnat_node)))
3998             expand_start_cond (gnat_to_gnu (Condition (gnat_node)), 0);
3999
4000           expand_expr_stmt (gnu_result);
4001           if (Present (Condition (gnat_node)))
4002             expand_end_cond ();
4003           gnu_result = error_mark_node;
4004         }
4005       else
4006         gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
4007       break;
4008
4009     /* Nothing to do, since front end does all validation using the
4010        values that Gigi back-annotates.  */
4011     case N_Validate_Unchecked_Conversion:
4012       break;
4013
4014     case N_Raise_Statement:
4015     case N_Function_Specification:
4016     case N_Procedure_Specification:
4017     case N_Op_Concat:
4018     case N_Component_Association:
4019     case N_Task_Body:
4020     default:
4021       if (! type_annotate_only)
4022         gigi_abort (321);
4023     }
4024
4025   /* If the result is a statement, set needed flags and return it.  */
4026   if (IS_STMT (gnu_result))
4027     {
4028       TREE_TYPE (gnu_result) = void_type_node;
4029       TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
4030       TREE_SLOC (gnu_result) = Sloc (gnat_node);
4031       return gnu_result;
4032     }
4033
4034   /* If the result is a constant that overflows, raise constraint error.  */
4035   else if (TREE_CODE (gnu_result) == INTEGER_CST
4036       && TREE_CONSTANT_OVERFLOW (gnu_result))
4037     {
4038       post_error ("Constraint_Error will be raised at run-time?", gnat_node);
4039
4040       gnu_result
4041         = build1 (NULL_EXPR, gnu_result_type,
4042                   build_call_raise (CE_Overflow_Check_Failed));
4043     }
4044
4045   /* If our result has side-effects and is of an unconstrained type,
4046      make a SAVE_EXPR so that we can be sure it will only be referenced
4047      once.  Note we must do this before any conversions.  */
4048   if (TREE_SIDE_EFFECTS (gnu_result)
4049       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
4050           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
4051     gnu_result = gnat_stabilize_reference (gnu_result, 0);
4052
4053   /* Now convert the result to the proper type.  If the type is void or if
4054      we have no result, return error_mark_node to show we have no result.
4055      If the type of the result is correct or if we have a label (which doesn't
4056      have any well-defined type), return our result.  Also don't do the
4057      conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4058      since those are the cases where the front end may have the type wrong due
4059      to "instantiating" the unconstrained record with discriminant values
4060      or if this is a FIELD_DECL.  If this is the Name of an assignment
4061      statement or a parameter of a procedure call, return what we have since
4062      the RHS has to be converted to our type there in that case, unless
4063      GNU_RESULT_TYPE has a simpler size.  Similarly, if the two types are
4064      record types with the same name, the expression type has integral mode,
4065      and GNU_RESULT_TYPE BLKmode, don't convert.  This will be the case when
4066      we are converting from a packable type to its actual type and we need
4067      those conversions to be NOPs in order for assignments into these types to
4068      work properly if the inner object is a bitfield and hence can't have
4069      its address taken.  Finally, don't convert integral types that are the
4070      operand of an unchecked conversion since we need to ignore those
4071      conversions (for 'Valid).  Otherwise, convert the result to the proper
4072      type.  */
4073
4074   if (Present (Parent (gnat_node))
4075       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
4076            && Name (Parent (gnat_node)) == gnat_node)
4077           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
4078               && Name (Parent (gnat_node)) != gnat_node)
4079           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
4080               && ! AGGREGATE_TYPE_P (gnu_result_type)
4081               && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4082           || Nkind (Parent (gnat_node)) == N_Parameter_Association)
4083       && ! (TYPE_SIZE (gnu_result_type) != 0
4084             && TYPE_SIZE (TREE_TYPE (gnu_result)) != 0
4085             && (AGGREGATE_TYPE_P (gnu_result_type)
4086                 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4087             && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
4088                  && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
4089                      != INTEGER_CST))
4090                 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4091                     && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
4092                     && (CONTAINS_PLACEHOLDER_P
4093                         (TYPE_SIZE (TREE_TYPE (gnu_result))))))
4094             && ! (TREE_CODE (gnu_result_type) == RECORD_TYPE
4095                   && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type))))
4096     {
4097       /* In this case remove padding only if the inner object is of
4098          self-referential size: in that case it must be an object of
4099          unconstrained type with a default discriminant.  In other cases,
4100          we want to avoid copying too much data.  */
4101       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4102           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
4103           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4104                                      (TREE_TYPE (TYPE_FIELDS
4105                                                  (TREE_TYPE (gnu_result))))))
4106         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4107                               gnu_result);
4108     }
4109
4110   else if (TREE_CODE (gnu_result) == LABEL_DECL
4111            || TREE_CODE (gnu_result) == FIELD_DECL
4112            || TREE_CODE (gnu_result) == ERROR_MARK
4113            || (TYPE_SIZE (gnu_result_type) != 0
4114                && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4115                && TREE_CODE (gnu_result) != INDIRECT_REF
4116                && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
4117            || ((TYPE_NAME (gnu_result_type)
4118                 == TYPE_NAME (TREE_TYPE (gnu_result)))
4119                && TREE_CODE (gnu_result_type) == RECORD_TYPE
4120                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4121                && TYPE_MODE (gnu_result_type) == BLKmode
4122                && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
4123                    == MODE_INT)))
4124     {
4125       /* Remove any padding record, but do nothing more in this case.  */
4126       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4127           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4128         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4129                               gnu_result);
4130     }
4131
4132   else if (gnu_result == error_mark_node
4133            || gnu_result_type == void_type_node)
4134     gnu_result =  error_mark_node;
4135   else if (gnu_result_type != TREE_TYPE (gnu_result))
4136     gnu_result = convert (gnu_result_type, gnu_result);
4137
4138   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT.  */
4139   while ((TREE_CODE (gnu_result) == NOP_EXPR
4140           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
4141          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
4142     gnu_result = TREE_OPERAND (gnu_result, 0);
4143
4144   return gnu_result;
4145 }
4146 \f
4147 /* GNU_STMT is a statement.  We generate code for that statement.  */
4148
4149 void
4150 gnat_expand_stmt (tree gnu_stmt)
4151 {
4152   set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
4153
4154   switch (TREE_CODE (gnu_stmt))
4155     {
4156     case EXPR_STMT:
4157       expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
4158       break;
4159
4160     default:
4161       abort ();
4162     }
4163 }
4164 \f
4165 /* Force references to each of the entities in packages GNAT_NODE with's
4166    so that the debugging information for all of them are identical
4167    in all clients.  Operate recursively on anything it with's, but check
4168    that we aren't elaborating something more than once.  */
4169
4170 /* The reason for this routine's existence is two-fold.
4171    First, with some debugging formats, notably MDEBUG on SGI
4172    IRIX, the linker will remove duplicate debugging information if two
4173    clients have identical debugguing information.  With the normal scheme
4174    of elaboration, this does not usually occur, since entities in with'ed
4175    packages are elaborated on demand, and if clients have different usage
4176    patterns, the normal case, then the order and selection of entities
4177    will differ.  In most cases however, it seems that linkers do not know
4178    how to eliminate duplicate debugging information, even if it is
4179    identical, so the use of this routine would increase the total amount
4180    of debugging information in the final executable.
4181
4182    Second, this routine is called in type_annotate mode, to compute DDA
4183    information for types in withed units, for ASIS use  */
4184
4185 static void
4186 elaborate_all_entities (Node_Id gnat_node)
4187 {
4188   Entity_Id gnat_with_clause, gnat_entity;
4189
4190   /* Process each unit only once. As we trace the context of all relevant
4191      units transitively, including generic bodies, we may encounter the
4192      same generic unit repeatedly */
4193
4194   if (!present_gnu_tree (gnat_node))
4195      save_gnu_tree (gnat_node, integer_zero_node, 1);
4196
4197   /* Save entities in all context units. A body may have an implicit_with
4198      on its own spec, if the context includes a child unit, so don't save
4199      the spec twice.  */
4200
4201   for (gnat_with_clause = First (Context_Items (gnat_node));
4202        Present (gnat_with_clause);
4203        gnat_with_clause = Next (gnat_with_clause))
4204     if (Nkind (gnat_with_clause) == N_With_Clause
4205         && ! present_gnu_tree (Library_Unit (gnat_with_clause))
4206         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
4207       {
4208         elaborate_all_entities (Library_Unit (gnat_with_clause));
4209
4210         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
4211           {
4212             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
4213                  Present (gnat_entity);
4214                  gnat_entity = Next_Entity (gnat_entity))
4215               if (Is_Public (gnat_entity)
4216                   && Convention (gnat_entity) != Convention_Intrinsic
4217                   && Ekind (gnat_entity) != E_Package
4218                   && Ekind (gnat_entity) != E_Package_Body
4219                   && Ekind (gnat_entity) != E_Operator
4220                   && ! (IN (Ekind (gnat_entity), Type_Kind)
4221                         && ! Is_Frozen (gnat_entity))
4222                   && ! ((Ekind (gnat_entity) == E_Procedure
4223                          || Ekind (gnat_entity) == E_Function)
4224                         && Is_Intrinsic_Subprogram (gnat_entity))
4225                   && ! IN (Ekind (gnat_entity), Named_Kind)
4226                   && ! IN (Ekind (gnat_entity), Generic_Unit_Kind))
4227                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4228           }
4229         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
4230            {
4231             Node_Id gnat_body
4232               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
4233
4234             /* Retrieve compilation unit node of generic body.  */
4235             while (Present (gnat_body)
4236                    && Nkind (gnat_body) != N_Compilation_Unit)
4237               gnat_body = Parent (gnat_body);
4238
4239             /* If body is available, elaborate its context.  */
4240             if (Present (gnat_body))
4241                 elaborate_all_entities (gnat_body);
4242            }
4243       }
4244
4245   if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
4246     elaborate_all_entities (Library_Unit (gnat_node));
4247 }
4248 \f
4249 /* Do the processing of N_Freeze_Entity, GNAT_NODE.  */
4250
4251 static void
4252 process_freeze_entity (Node_Id gnat_node)
4253 {
4254   Entity_Id gnat_entity = Entity (gnat_node);
4255   tree gnu_old;
4256   tree gnu_new;
4257   tree gnu_init
4258     = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
4259        && present_gnu_tree (Declaration_Node (gnat_entity)))
4260       ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
4261
4262   /* If this is a package, need to generate code for the package.  */
4263   if (Ekind (gnat_entity) == E_Package)
4264     {
4265       insert_code_for
4266         (Parent (Corresponding_Body
4267                  (Parent (Declaration_Node (gnat_entity)))));
4268       return;
4269     }
4270
4271   /* Check for old definition after the above call.  This Freeze_Node
4272      might be for one its Itypes.  */
4273   gnu_old
4274     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4275
4276   /* If this entity has an Address representation clause, GNU_OLD is the
4277      address, so discard it here.  */
4278   if (Present (Address_Clause (gnat_entity)))
4279     gnu_old = 0;
4280
4281   /* Don't do anything for class-wide types they are always
4282      transformed into their root type.  */
4283   if (Ekind (gnat_entity) == E_Class_Wide_Type
4284       || (Ekind (gnat_entity) == E_Class_Wide_Subtype
4285           && Present (Equivalent_Type (gnat_entity))))
4286     return;
4287
4288   /* Don't do anything for subprograms that may have been elaborated before
4289      their freeze nodes.  This can happen, for example because of an inner call
4290      in an instance body.  */
4291   if (gnu_old != 0
4292        && TREE_CODE (gnu_old) == FUNCTION_DECL
4293        && (Ekind (gnat_entity) == E_Function
4294           || Ekind (gnat_entity) == E_Procedure))
4295     return;
4296
4297   /* If we have a non-dummy type old tree, we have nothing to do.   Unless
4298      this is the public view of a private type whose full view was not
4299      delayed, this node was never delayed as it should have been.
4300      Also allow this to happen for concurrent types since we may have
4301      frozen both the Corresponding_Record_Type and this type.  */
4302   if (gnu_old != 0
4303       && ! (TREE_CODE (gnu_old) == TYPE_DECL
4304             && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
4305     {
4306       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4307           && Present (Full_View (gnat_entity))
4308           && No (Freeze_Node (Full_View (gnat_entity))))
4309         return;
4310       else if (Is_Concurrent_Type (gnat_entity))
4311         return;
4312       else
4313         gigi_abort (320);
4314     }
4315
4316   /* Reset the saved tree, if any, and elaborate the object or type for real.
4317      If there is a full declaration, elaborate it and copy the type to
4318      GNAT_ENTITY.  Likewise if this is the record subtype corresponding to
4319      a class wide type or subtype.  */
4320   if (gnu_old != 0)
4321     {
4322       save_gnu_tree (gnat_entity, NULL_TREE, 0);
4323       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4324           && Present (Full_View (gnat_entity))
4325           && present_gnu_tree (Full_View (gnat_entity)))
4326         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, 0);
4327       if (Present (Class_Wide_Type (gnat_entity))
4328           && Class_Wide_Type (gnat_entity) != gnat_entity)
4329         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, 0);
4330     }
4331
4332   if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4333       && Present (Full_View (gnat_entity)))
4334     {
4335       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
4336
4337       /* The above call may have defined this entity (the simplest example
4338          of this is when we have a private enumeral type since the bounds
4339          will have the public view.  */
4340       if (! present_gnu_tree (gnat_entity))
4341         save_gnu_tree (gnat_entity, gnu_new, 0);
4342       if (Present (Class_Wide_Type (gnat_entity))
4343           && Class_Wide_Type (gnat_entity) != gnat_entity)
4344         save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, 0);
4345     }
4346   else
4347     gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
4348
4349   /* If we've made any pointers to the old version of this type, we
4350      have to update them.  */
4351   if (gnu_old != 0)
4352     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4353                        TREE_TYPE (gnu_new));
4354 }
4355 \f
4356 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4357    N_Compilation_Unit.  */
4358
4359 static void
4360 process_inlined_subprograms (Node_Id gnat_node)
4361 {
4362   Entity_Id gnat_entity;
4363   Node_Id gnat_body;
4364
4365   /* If we can inline, generate RTL for all the inlined subprograms.
4366      Define the entity first so we set DECL_EXTERNAL.  */
4367   if (optimize > 0 && ! flag_no_inline)
4368     for (gnat_entity = First_Inlined_Subprogram (gnat_node);
4369          Present (gnat_entity);
4370          gnat_entity = Next_Inlined_Subprogram (gnat_entity))
4371       {
4372         gnat_body = Parent (Declaration_Node (gnat_entity));
4373
4374         if (Nkind (gnat_body) != N_Subprogram_Body)
4375           {
4376             /* ??? This really should always be Present.  */
4377             if (No (Corresponding_Body (gnat_body)))
4378               continue;
4379
4380             gnat_body
4381               = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
4382           }
4383
4384         if (Present (gnat_body))
4385           {
4386             gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4387             gnat_to_code (gnat_body);
4388           }
4389       }
4390 }
4391 \f
4392 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4393    We make two passes, one to elaborate anything other than bodies (but
4394    we declare a function if there was no spec).  The second pass
4395    elaborates the bodies.
4396
4397    GNAT_END_LIST gives the element in the list past the end.  Normally,
4398    this is Empty, but can be First_Real_Statement for a
4399    Handled_Sequence_Of_Statements.
4400
4401    We make a complete pass through both lists if PASS1P is true, then make
4402    the second pass over both lists if PASS2P is true.  The lists usually
4403    correspond to the public and private parts of a package.  */
4404
4405 static void
4406 process_decls (List_Id gnat_decls,
4407                List_Id gnat_decls2,
4408                Node_Id gnat_end_list,
4409                int pass1p,
4410                int pass2p)
4411 {
4412   List_Id gnat_decl_array[2];
4413   Node_Id gnat_decl;
4414   int i;
4415
4416   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
4417
4418   if (pass1p)
4419     for (i = 0; i <= 1; i++)
4420       if (Present (gnat_decl_array[i]))
4421         for (gnat_decl = First (gnat_decl_array[i]);
4422              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4423           {
4424             set_lineno (gnat_decl, 0);
4425
4426             /* For package specs, we recurse inside the declarations,
4427                thus taking the two pass approach inside the boundary.  */
4428             if (Nkind (gnat_decl) == N_Package_Declaration
4429                 && (Nkind (Specification (gnat_decl)
4430                            == N_Package_Specification)))
4431               process_decls (Visible_Declarations (Specification (gnat_decl)),
4432                              Private_Declarations (Specification (gnat_decl)),
4433                              Empty, 1, 0);
4434
4435             /* Similarly for any declarations in the actions of a
4436                freeze node.  */
4437             else if (Nkind (gnat_decl) == N_Freeze_Entity)
4438               {
4439                 process_freeze_entity (gnat_decl);
4440                 process_decls (Actions (gnat_decl), Empty, Empty, 1, 0);
4441               }
4442
4443             /* Package bodies with freeze nodes get their elaboration deferred
4444                until the freeze node, but the code must be placed in the right
4445                place, so record the code position now.  */
4446             else if (Nkind (gnat_decl) == N_Package_Body
4447                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
4448               record_code_position (gnat_decl);
4449
4450             else if (Nkind (gnat_decl) == N_Package_Body_Stub
4451                      && Present (Library_Unit (gnat_decl))
4452                      && Present (Freeze_Node
4453                                  (Corresponding_Spec
4454                                   (Proper_Body (Unit
4455                                                 (Library_Unit (gnat_decl)))))))
4456               record_code_position
4457                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
4458
4459             /* We defer most subprogram bodies to the second pass.  */
4460             else if (Nkind (gnat_decl) == N_Subprogram_Body)
4461               {
4462                 if (Acts_As_Spec (gnat_decl))
4463                   {
4464                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
4465
4466                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
4467                         && Ekind (gnat_subprog_id) != E_Generic_Function)
4468                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4469                   }
4470               }
4471             /* For bodies and stubs that act as their own specs, the entity
4472                itself must be elaborated in the first pass, because it may
4473                be used in other declarations. */
4474             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
4475               {
4476                   Node_Id gnat_subprog_id =
4477                      Defining_Entity (Specification (gnat_decl));
4478
4479                     if    (Ekind (gnat_subprog_id) != E_Subprogram_Body
4480                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
4481                         && Ekind (gnat_subprog_id) != E_Generic_Function)
4482                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4483                }
4484
4485             /* Concurrent stubs stand for the corresponding subprogram bodies,
4486                which are deferred like other bodies.  */
4487               else if (Nkind (gnat_decl) == N_Task_Body_Stub
4488                        || Nkind (gnat_decl) == N_Protected_Body_Stub)
4489                 ;
4490
4491             else
4492               gnat_to_code (gnat_decl);
4493           }
4494
4495   /* Here we elaborate everything we deferred above except for package bodies,
4496      which are elaborated at their freeze nodes.  Note that we must also
4497      go inside things (package specs and freeze nodes) the first pass did.  */
4498   if (pass2p)
4499     for (i = 0; i <= 1; i++)
4500       if (Present (gnat_decl_array[i]))
4501         for (gnat_decl = First (gnat_decl_array[i]);
4502              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4503           {
4504             if (Nkind (gnat_decl) == N_Subprogram_Body
4505                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
4506                 || Nkind (gnat_decl) == N_Task_Body_Stub
4507                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
4508               gnat_to_code (gnat_decl);
4509
4510             else if (Nkind (gnat_decl) == N_Package_Declaration
4511                      && (Nkind (Specification (gnat_decl)
4512                                 == N_Package_Specification)))
4513               process_decls (Visible_Declarations (Specification (gnat_decl)),
4514                              Private_Declarations (Specification (gnat_decl)),
4515                              Empty, 0, 1);
4516
4517             else if (Nkind (gnat_decl) == N_Freeze_Entity)
4518               process_decls (Actions (gnat_decl), Empty, Empty, 0, 1);
4519           }
4520 }
4521 \f
4522 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4523    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4524    which we have to check. */
4525
4526 static tree
4527 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
4528 {
4529   tree gnu_range_type = get_unpadded_type (gnat_range_type);
4530   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
4531   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4532   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
4533
4534   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4535      we can't do anything since we might be truncating the bounds.  No
4536      check is needed in this case.  */
4537   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
4538       && (TYPE_PRECISION (gnu_compare_type)
4539           < TYPE_PRECISION (get_base_type (gnu_range_type))))
4540     return gnu_expr;
4541
4542   /* Checked expressions must be evaluated only once. */
4543   gnu_expr = protect_multiple_eval (gnu_expr);
4544
4545   /* There's no good type to use here, so we might as well use
4546      integer_type_node. Note that the form of the check is
4547         (not (expr >= lo)) or (not (expr >= hi))
4548       the reason for this slightly convoluted form is that NaN's
4549       are not considered to be in range in the float case. */
4550   return emit_check
4551     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4552                       invert_truthvalue
4553                       (build_binary_op (GE_EXPR, integer_type_node,
4554                                        convert (gnu_compare_type, gnu_expr),
4555                                        convert (gnu_compare_type, gnu_low))),
4556                       invert_truthvalue
4557                       (build_binary_op (LE_EXPR, integer_type_node,
4558                                         convert (gnu_compare_type, gnu_expr),
4559                                         convert (gnu_compare_type,
4560                                                  gnu_high)))),
4561      gnu_expr, CE_Range_Check_Failed);
4562 }
4563 \f
4564 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4565    which we are about to index, GNU_EXPR is the index expression to be
4566    checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4567    against which GNU_EXPR has to be checked. Note that for index
4568    checking we cannot use the emit_range_check function (although very
4569    similar code needs to be generated in both cases) since for index
4570    checking the array type against which we are checking the indeces
4571    may be unconstrained and consequently we need to retrieve the
4572    actual index bounds from the array object itself
4573    (GNU_ARRAY_OBJECT). The place where we need to do that is in
4574    subprograms having unconstrained array formal parameters */
4575
4576 static tree
4577 emit_index_check (tree gnu_array_object,
4578                   tree gnu_expr,
4579                   tree gnu_low,
4580                   tree gnu_high)
4581 {
4582   tree gnu_expr_check;
4583
4584   /* Checked expressions must be evaluated only once. */
4585   gnu_expr = protect_multiple_eval (gnu_expr);
4586
4587   /* Must do this computation in the base type in case the expression's
4588      type is an unsigned subtypes.  */
4589   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
4590
4591   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4592      the object we are handling. */
4593   if (CONTAINS_PLACEHOLDER_P (gnu_low))
4594     gnu_low = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_low),
4595                      gnu_low, gnu_array_object);
4596
4597   if (CONTAINS_PLACEHOLDER_P (gnu_high))
4598     gnu_high = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_high),
4599                       gnu_high, gnu_array_object);
4600
4601   /* There's no good type to use here, so we might as well use
4602      integer_type_node.   */
4603   return emit_check
4604     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4605                       build_binary_op (LT_EXPR, integer_type_node,
4606                                        gnu_expr_check,
4607                                        convert (TREE_TYPE (gnu_expr_check),
4608                                                 gnu_low)),
4609                       build_binary_op (GT_EXPR, integer_type_node,
4610                                        gnu_expr_check,
4611                                        convert (TREE_TYPE (gnu_expr_check),
4612                                                 gnu_high))),
4613      gnu_expr, CE_Index_Check_Failed);
4614 }
4615 \f
4616 /* Given GNU_COND which contains the condition corresponding to an access,
4617    discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4618    that returns GNU_EXPR if GNU_COND is false and raises a
4619    CONSTRAINT_ERROR if GNU_COND is true.  REASON is the code that says
4620    why the exception was raised.  */
4621
4622 static tree
4623 emit_check (tree gnu_cond, tree gnu_expr, int reason)
4624 {
4625   tree gnu_call;
4626   tree gnu_result;
4627
4628   gnu_call = build_call_raise (reason);
4629
4630   /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
4631      in front of the comparison in case it ends up being a SAVE_EXPR.  Put the
4632      whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
4633      out.  */
4634   gnu_result = fold (build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
4635                             build (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
4636                                    gnu_call, gnu_expr),
4637                             gnu_expr));
4638
4639   /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
4640      protect it.  Otherwise, show GNU_RESULT has no side effects: we
4641      don't need to evaluate it just for the check.  */
4642   if (TREE_SIDE_EFFECTS (gnu_expr))
4643     gnu_result
4644       = build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
4645   else
4646     TREE_SIDE_EFFECTS (gnu_result) = 0;
4647
4648   /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
4649      we will repeatedly do the test.  It would be nice if GCC was able
4650      to optimize this and only do it once.  */
4651   return save_expr (gnu_result);
4652 }
4653 \f
4654 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4655    overflow checks if OVERFLOW_P is nonzero and range checks if
4656    RANGE_P is nonzero.  GNAT_TYPE is known to be an integral type.
4657    If TRUNCATE_P is nonzero, do a float to integer conversion with
4658    truncation; otherwise round.  */
4659
4660 static tree
4661 convert_with_check (Entity_Id gnat_type,
4662                     tree gnu_expr,
4663                     int overflow_p,
4664                     int range_p,
4665                     int truncate_p)
4666 {
4667   tree gnu_type = get_unpadded_type (gnat_type);
4668   tree gnu_in_type = TREE_TYPE (gnu_expr);
4669   tree gnu_in_basetype = get_base_type (gnu_in_type);
4670   tree gnu_base_type = get_base_type (gnu_type);
4671   tree gnu_ada_base_type = get_ada_base_type (gnu_type);
4672   tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
4673   tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
4674   tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
4675   tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
4676   tree gnu_result = gnu_expr;
4677
4678   /* If we are not doing any checks, the output is an integral type, and
4679      the input is not a floating type, just do the conversion.  This
4680      shortcut is required to avoid problems with packed array types
4681      and simplifies code in all cases anyway.   */
4682   if (! range_p && ! overflow_p && INTEGRAL_TYPE_P (gnu_base_type)
4683       && ! FLOAT_TYPE_P (gnu_in_type))
4684     return convert (gnu_type, gnu_expr);
4685
4686   /* First convert the expression to its base type.  This
4687      will never generate code, but makes the tests below much simpler.
4688      But don't do this if converting from an integer type to an unconstrained
4689      array type since then we need to get the bounds from the original
4690      (unpacked) type.  */
4691   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
4692     gnu_result = convert (gnu_in_basetype, gnu_result);
4693
4694   /* If overflow checks are requested,  we need to be sure the result will
4695      fit in the output base type.  But don't do this if the input
4696      is integer and the output floating-point.  */
4697   if (overflow_p
4698       && ! (FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
4699     {
4700       /* Ensure GNU_EXPR only gets evaluated once.  */
4701       tree gnu_input = protect_multiple_eval (gnu_result);
4702       tree gnu_cond = integer_zero_node;
4703
4704       /* Convert the lower bounds to signed types, so we're sure we're
4705          comparing them properly.  Likewise, convert the upper bounds
4706          to unsigned types.  */
4707       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TREE_UNSIGNED (gnu_in_basetype))
4708         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
4709
4710       if (INTEGRAL_TYPE_P (gnu_in_basetype)
4711           && ! TREE_UNSIGNED (gnu_in_basetype))
4712         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
4713
4714       if (INTEGRAL_TYPE_P (gnu_base_type) && TREE_UNSIGNED (gnu_base_type))
4715         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
4716
4717       if (INTEGRAL_TYPE_P (gnu_base_type) && ! TREE_UNSIGNED (gnu_base_type))
4718         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
4719
4720       /* Check each bound separately and only if the result bound
4721          is tighter than the bound on the input type.  Note that all the
4722          types are base types, so the bounds must be constant. Also,
4723          the comparison is done in the base type of the input, which
4724          always has the proper signedness.  First check for input
4725          integer (which means output integer), output float (which means
4726          both float), or mixed, in which case we always compare.
4727          Note that we have to do the comparison which would *fail* in the
4728          case of an error since if it's an FP comparison and one of the
4729          values is a NaN or Inf, the comparison will fail.  */
4730       if (INTEGRAL_TYPE_P (gnu_in_basetype)
4731           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
4732           : (FLOAT_TYPE_P (gnu_base_type)
4733              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
4734                                  TREE_REAL_CST (gnu_out_lb))
4735              : 1))
4736         gnu_cond
4737           = invert_truthvalue
4738             (build_binary_op (GE_EXPR, integer_type_node,
4739                               gnu_input, convert (gnu_in_basetype,
4740                                                   gnu_out_lb)));
4741
4742       if (INTEGRAL_TYPE_P (gnu_in_basetype)
4743           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
4744           : (FLOAT_TYPE_P (gnu_base_type)
4745              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
4746                                  TREE_REAL_CST (gnu_in_lb))
4747              : 1))
4748         gnu_cond
4749           = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
4750                              invert_truthvalue
4751                              (build_binary_op (LE_EXPR, integer_type_node,
4752                                                gnu_input,
4753                                                convert (gnu_in_basetype,
4754                                                         gnu_out_ub))));
4755
4756       if (! integer_zerop (gnu_cond))
4757         gnu_result = emit_check (gnu_cond, gnu_input,
4758                                  CE_Overflow_Check_Failed);
4759     }
4760
4761   /* Now convert to the result base type.  If this is a non-truncating
4762      float-to-integer conversion, round.  */
4763   if (INTEGRAL_TYPE_P (gnu_ada_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
4764       && ! truncate_p)
4765     {
4766       tree gnu_point_5 = build_real (gnu_in_basetype, dconstp5);
4767       tree gnu_minus_point_5 = build_real (gnu_in_basetype, dconstmp5);
4768       tree gnu_zero = convert (gnu_in_basetype, integer_zero_node);
4769       tree gnu_saved_result = save_expr (gnu_result);
4770       tree gnu_comp = build (GE_EXPR, integer_type_node,
4771                              gnu_saved_result, gnu_zero);
4772       tree gnu_adjust = build (COND_EXPR, gnu_in_basetype, gnu_comp,
4773                                gnu_point_5, gnu_minus_point_5);
4774
4775       gnu_result
4776         = build (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
4777     }
4778
4779   if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
4780       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type)
4781       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
4782     gnu_result = unchecked_convert (gnu_ada_base_type, gnu_result, 0);
4783   else
4784     gnu_result = convert (gnu_ada_base_type, gnu_result);
4785
4786   /* Finally, do the range check if requested.  Note that if the
4787      result type is a modular type, the range check is actually
4788      an overflow check.  */
4789
4790   if (range_p
4791       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
4792           && TYPE_MODULAR_P (gnu_base_type) && overflow_p))
4793     gnu_result = emit_range_check (gnu_result, gnat_type);
4794
4795   return convert (gnu_type, gnu_result);
4796 }
4797 \f
4798 /* Return 1 if GNU_EXPR can be directly addressed.  This is the case unless
4799    it is an expression involving computation or if it involves a bitfield
4800    reference.  This returns the same as gnat_mark_addressable in most
4801    cases.  */
4802
4803 static int
4804 addressable_p (tree gnu_expr)
4805 {
4806   switch (TREE_CODE (gnu_expr))
4807     {
4808     case VAR_DECL:
4809     case PARM_DECL:
4810     case FUNCTION_DECL:
4811     case RESULT_DECL:
4812       /* All DECLs are addressable: if they are in a register, we can force
4813          them to memory.  */
4814       return 1;
4815
4816     case UNCONSTRAINED_ARRAY_REF:
4817     case INDIRECT_REF:
4818     case CONSTRUCTOR:
4819     case NULL_EXPR:
4820     case SAVE_EXPR:
4821       return 1;
4822
4823     case COMPONENT_REF:
4824       return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
4825               && (! DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr, 1))
4826                   || ! flag_strict_aliasing)
4827               && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4828
4829     case ARRAY_REF:  case ARRAY_RANGE_REF:
4830     case REALPART_EXPR:  case IMAGPART_EXPR:
4831     case NOP_EXPR:
4832       return addressable_p (TREE_OPERAND (gnu_expr, 0));
4833
4834     case CONVERT_EXPR:
4835       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
4836               && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4837
4838     case VIEW_CONVERT_EXPR:
4839       {
4840         /* This is addressable if we can avoid a copy.  */
4841         tree type = TREE_TYPE (gnu_expr);
4842         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
4843
4844         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
4845                   && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
4846                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
4847                  || ((TYPE_MODE (type) == BLKmode
4848                       || TYPE_MODE (inner_type) == BLKmode)
4849                      && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
4850                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
4851                          || TYPE_ALIGN_OK (type)
4852                          || TYPE_ALIGN_OK (inner_type))))
4853                 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4854       }
4855
4856     default:
4857       return 0;
4858     }
4859 }
4860 \f
4861 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
4862    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
4863    make a GCC type for GNAT_ENTITY and set up the correspondance.  */
4864
4865 void
4866 process_type (Entity_Id gnat_entity)
4867 {
4868   tree gnu_old
4869     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4870   tree gnu_new;
4871
4872   /* If we are to delay elaboration of this type, just do any
4873      elaborations needed for expressions within the declaration and
4874      make a dummy type entry for this node and its Full_View (if
4875      any) in case something points to it.  Don't do this if it
4876      has already been done (the only way that can happen is if
4877      the private completion is also delayed).  */
4878   if (Present (Freeze_Node (gnat_entity))
4879       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4880           && Present (Full_View (gnat_entity))
4881           && Freeze_Node (Full_View (gnat_entity))
4882           && ! present_gnu_tree (Full_View (gnat_entity))))
4883     {
4884       elaborate_entity (gnat_entity);
4885
4886       if (gnu_old == 0)
4887         {
4888           tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
4889                                             make_dummy_type (gnat_entity),
4890                                             0, 0, 0);
4891
4892           save_gnu_tree (gnat_entity, gnu_decl, 0);
4893           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4894               && Present (Full_View (gnat_entity)))
4895             save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
4896         }
4897
4898       return;
4899     }
4900
4901   /* If we saved away a dummy type for this node it means that this
4902      made the type that corresponds to the full type of an incomplete
4903      type.  Clear that type for now and then update the type in the
4904      pointers.  */
4905   if (gnu_old != 0)
4906     {
4907       if (TREE_CODE (gnu_old) != TYPE_DECL
4908           || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
4909         {
4910           /* If this was a withed access type, this is not an error
4911              and merely indicates we've already elaborated the type
4912              already. */
4913           if (Is_Type (gnat_entity) && From_With_Type (gnat_entity))
4914             return;
4915
4916           gigi_abort (323);
4917         }
4918
4919       save_gnu_tree (gnat_entity, NULL_TREE, 0);
4920     }
4921
4922   /* Now fully elaborate the type.  */
4923   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
4924   if (TREE_CODE (gnu_new) != TYPE_DECL)
4925     gigi_abort (324);
4926
4927   /* If we have an old type and we've made pointers to this type,
4928      update those pointers.  */
4929   if (gnu_old != 0)
4930     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4931                        TREE_TYPE (gnu_new));
4932
4933   /* If this is a record type corresponding to a task or protected type
4934      that is a completion of an incomplete type, perform a similar update
4935      on the type.  */
4936   /* ??? Including protected types here is a guess. */
4937
4938   if (IN (Ekind (gnat_entity), Record_Kind)
4939       && Is_Concurrent_Record_Type (gnat_entity)
4940       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
4941     {
4942       tree gnu_task_old
4943         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
4944
4945       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
4946                      NULL_TREE, 0);
4947       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
4948                      gnu_new, 0);
4949
4950       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
4951                          TREE_TYPE (gnu_new));
4952     }
4953 }
4954 \f
4955 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
4956    GNU_TYPE is the GCC type of the corresponding record.
4957
4958    Return a CONSTRUCTOR to build the record.  */
4959
4960 static tree
4961 assoc_to_constructor (Node_Id gnat_assoc, tree gnu_type)
4962 {
4963   tree gnu_field, gnu_list, gnu_result;
4964
4965   /* We test for GNU_FIELD being empty in the case where a variant
4966      was the last thing since we don't take things off GNAT_ASSOC in
4967      that case.  We check GNAT_ASSOC in case we have a variant, but it
4968      has no fields.  */
4969
4970   for (gnu_list = NULL_TREE; Present (gnat_assoc);
4971        gnat_assoc = Next (gnat_assoc))
4972     {
4973       Node_Id gnat_field = First (Choices (gnat_assoc));
4974       tree gnu_field = gnat_to_gnu_entity (Entity (gnat_field), NULL_TREE, 0);
4975       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
4976
4977       /* The expander is supposed to put a single component selector name
4978          in every record component association */
4979       if (Next (gnat_field))
4980         gigi_abort (328);
4981
4982       /* Before assigning a value in an aggregate make sure range checks
4983          are done if required.  Then convert to the type of the field.  */
4984       if (Do_Range_Check (Expression (gnat_assoc)))
4985         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
4986
4987       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
4988
4989       /* Add the field and expression to the list.  */
4990       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
4991     }
4992
4993   gnu_result = extract_values (gnu_list, gnu_type);
4994
4995   /* Verify every enty in GNU_LIST was used.  */
4996   for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
4997     if (! TREE_ADDRESSABLE (gnu_field))
4998       gigi_abort (311);
4999
5000   return gnu_result;
5001 }
5002
5003 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
5004    is the first element of an array aggregate. It may itself be an
5005    aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
5006    corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
5007    of the array component. It is needed for range checking. */
5008
5009 static tree
5010 pos_to_constructor (Node_Id gnat_expr,
5011                     tree gnu_array_type,
5012                     Entity_Id gnat_component_type)
5013 {
5014   tree gnu_expr;
5015   tree gnu_expr_list = NULL_TREE;
5016
5017   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
5018     {
5019       /* If the expression is itself an array aggregate then first build the
5020          innermost constructor if it is part of our array (multi-dimensional
5021          case).  */
5022
5023       if (Nkind (gnat_expr) == N_Aggregate
5024           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
5025           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
5026         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
5027                                        TREE_TYPE (gnu_array_type),
5028                                        gnat_component_type);
5029       else
5030         {
5031           gnu_expr = gnat_to_gnu (gnat_expr);
5032
5033           /* before assigning the element to the array make sure it is
5034              in range */
5035           if (Do_Range_Check (gnat_expr))
5036             gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
5037         }
5038
5039       gnu_expr_list
5040         = tree_cons (NULL_TREE, convert (TREE_TYPE (gnu_array_type), gnu_expr),
5041                      gnu_expr_list);
5042     }
5043
5044   return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
5045 }
5046 \f
5047 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5048    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
5049    of the associations that are from RECORD_TYPE.  If we see an internal
5050    record, make a recursive call to fill it in as well.  */
5051
5052 static tree
5053 extract_values (tree values, tree record_type)
5054 {
5055   tree result = NULL_TREE;
5056   tree field, tem;
5057
5058   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
5059     {
5060       tree value = 0;
5061
5062       /* _Parent is an internal field, but may have values in the aggregate,
5063          so check for values first.  */
5064       if ((tem = purpose_member (field, values)) != 0)
5065         {
5066           value = TREE_VALUE (tem);
5067           TREE_ADDRESSABLE (tem) = 1;
5068         }
5069
5070       else if (DECL_INTERNAL_P (field))
5071         {
5072           value = extract_values (values, TREE_TYPE (field));
5073           if (TREE_CODE (value) == CONSTRUCTOR
5074               && CONSTRUCTOR_ELTS (value) == 0)
5075             value = 0;
5076         }
5077       else
5078         /* If we have a record subtype, the names will match, but not the
5079            actual FIELD_DECLs.  */
5080         for (tem = values; tem; tem = TREE_CHAIN (tem))
5081           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
5082             {
5083               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
5084               TREE_ADDRESSABLE (tem) = 1;
5085             }
5086
5087       if (value == 0)
5088         continue;
5089
5090       result = tree_cons (field, value, result);
5091     }
5092
5093   return gnat_build_constructor (record_type, nreverse (result));
5094 }
5095 \f
5096 /* EXP is to be treated as an array or record.  Handle the cases when it is
5097    an access object and perform the required dereferences.  */
5098
5099 static tree
5100 maybe_implicit_deref (tree exp)
5101 {
5102   /* If the type is a pointer, dereference it.  */
5103
5104   if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
5105     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
5106
5107   /* If we got a padded type, remove it too.  */
5108   if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
5109       && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
5110     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
5111
5112   return exp;
5113 }
5114 \f
5115 /* Protect EXP from multiple evaluation.  This may make a SAVE_EXPR.  */
5116
5117 tree
5118 protect_multiple_eval (tree exp)
5119 {
5120   tree type = TREE_TYPE (exp);
5121
5122   /* If this has no side effects, we don't need to do anything.  */
5123   if (! TREE_SIDE_EFFECTS (exp))
5124     return exp;
5125
5126   /* If it is a conversion, protect what's inside the conversion.
5127      Similarly, if we're indirectly referencing something, we only
5128      actually need to protect the address since the data itself can't
5129      change in these situations.  */
5130   else if (TREE_CODE (exp) == NON_LVALUE_EXPR
5131            || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR
5132            || TREE_CODE (exp) == VIEW_CONVERT_EXPR
5133            || TREE_CODE (exp) == INDIRECT_REF
5134            || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
5135     return build1 (TREE_CODE (exp), type,
5136                    protect_multiple_eval (TREE_OPERAND (exp, 0)));
5137
5138   /* If EXP is a fat pointer or something that can be placed into a register,
5139      just make a SAVE_EXPR.  */
5140   if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
5141     return save_expr (exp);
5142
5143   /* Otherwise, dereference, protect the address, and re-reference.  */
5144   else
5145     return
5146       build_unary_op (INDIRECT_REF, type,
5147                       save_expr (build_unary_op (ADDR_EXPR,
5148                                                  build_reference_type (type),
5149                                                  exp)));
5150 }
5151 \f
5152 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5153    how to handle our new nodes and we take an extra argument that says
5154    whether to force evaluation of everything.  */
5155
5156 tree
5157 gnat_stabilize_reference (tree ref, int force)
5158 {
5159   register tree type = TREE_TYPE (ref);
5160   register enum tree_code code = TREE_CODE (ref);
5161   register tree result;
5162
5163   switch (code)
5164     {
5165     case VAR_DECL:
5166     case PARM_DECL:
5167     case RESULT_DECL:
5168       /* No action is needed in this case.  */
5169       return ref;
5170
5171     case NOP_EXPR:
5172     case CONVERT_EXPR:
5173     case FLOAT_EXPR:
5174     case FIX_TRUNC_EXPR:
5175     case FIX_FLOOR_EXPR:
5176     case FIX_ROUND_EXPR:
5177     case FIX_CEIL_EXPR:
5178     case VIEW_CONVERT_EXPR:
5179     case ADDR_EXPR:
5180       result
5181         = build1 (code, type,
5182                   gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
5183       break;
5184
5185     case INDIRECT_REF:
5186     case UNCONSTRAINED_ARRAY_REF:
5187       result = build1 (code, type,
5188                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5189                                                    force));
5190       break;
5191
5192     case COMPONENT_REF:
5193       result = build (COMPONENT_REF, type,
5194                       gnat_stabilize_reference (TREE_OPERAND (ref, 0),
5195                                                 force),
5196                       TREE_OPERAND (ref, 1));
5197       break;
5198
5199     case BIT_FIELD_REF:
5200       result = build (BIT_FIELD_REF, type,
5201                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5202                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5203                                                      force),
5204                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
5205                                                   force));
5206       break;
5207
5208     case ARRAY_REF:
5209       result = build (ARRAY_REF, type,
5210                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5211                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5212                                                   force));
5213       break;
5214
5215     case ARRAY_RANGE_REF:
5216       result = build (ARRAY_RANGE_REF, type,
5217                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5218                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5219                                                   force));
5220       break;
5221
5222     case COMPOUND_EXPR:
5223       result = build (COMPOUND_EXPR, type,
5224                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5225                                                   force),
5226                       gnat_stabilize_reference (TREE_OPERAND (ref, 1),
5227                                                 force));
5228       break;
5229
5230     case RTL_EXPR:
5231       result = build1 (INDIRECT_REF, type,
5232                        save_expr (build1 (ADDR_EXPR,
5233                                           build_reference_type (type), ref)));
5234       break;
5235
5236       /* If arg isn't a kind of lvalue we recognize, make no change.
5237          Caller should recognize the error for an invalid lvalue.  */
5238     default:
5239       return ref;
5240
5241     case ERROR_MARK:
5242       return error_mark_node;
5243     }
5244
5245   TREE_READONLY (result) = TREE_READONLY (ref);
5246   return result;
5247 }
5248
5249 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5250    arg to force a SAVE_EXPR for everything.  */
5251
5252 static tree
5253 gnat_stabilize_reference_1 (tree e, int force)
5254 {
5255   register enum tree_code code = TREE_CODE (e);
5256   register tree type = TREE_TYPE (e);
5257   register tree result;
5258
5259   /* We cannot ignore const expressions because it might be a reference
5260      to a const array but whose index contains side-effects.  But we can
5261      ignore things that are actual constant or that already have been
5262      handled by this function.  */
5263
5264   if (TREE_CONSTANT (e) || code == SAVE_EXPR)
5265     return e;
5266
5267   switch (TREE_CODE_CLASS (code))
5268     {
5269     case 'x':
5270     case 't':
5271     case 'd':
5272     case 'b':
5273     case '<':
5274     case 's':
5275     case 'e':
5276     case 'r':
5277       if (TREE_SIDE_EFFECTS (e) || force)
5278         return save_expr (e);
5279       return e;
5280
5281     case 'c':
5282       /* Constants need no processing.  In fact, we should never reach
5283          here.  */
5284       return e;
5285
5286     case '2':
5287       /* Recursively stabilize each operand.  */
5288       result = build (code, type,
5289                       gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
5290                       gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
5291       break;
5292
5293     case '1':
5294       /* Recursively stabilize each operand.  */
5295       result = build1 (code, type,
5296                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
5297                                                    force));
5298       break;
5299
5300     default:
5301       abort ();
5302     }
5303
5304   TREE_READONLY (result) = TREE_READONLY (e);
5305   return result;
5306 }
5307 \f
5308 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5309    either a spec or a body, BODY_P says which.  If needed, make a function
5310    to be the elaboration routine for that object and perform the elaborations
5311    in GNU_ELAB_LIST.
5312
5313    Return 1 if we didn't need an elaboration function, zero otherwise.  */
5314
5315 static int
5316 build_unit_elab (Entity_Id gnat_unit, int body_p, tree gnu_elab_list)
5317 {
5318   tree gnu_decl;
5319   rtx insn;
5320   int result = 1;
5321
5322   /* If we have nothing to do, return.  */
5323   if (gnu_elab_list == 0)
5324     return 1;
5325
5326   /* Prevent the elaboration list from being reclaimed by the GC.  */
5327   gnu_pending_elaboration_lists = chainon (gnu_pending_elaboration_lists,
5328                                            gnu_elab_list);
5329
5330   /* Set our file and line number to that of the object and set up the
5331      elaboration routine.  */
5332   gnu_decl = create_subprog_decl (create_concat_name (gnat_unit,
5333                                                       body_p ?
5334                                                       "elabb" : "elabs"),
5335                                   NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0,
5336                                   0);
5337   DECL_ELABORATION_PROC_P (gnu_decl) = 1;
5338
5339   begin_subprog_body (gnu_decl);
5340   set_lineno (gnat_unit, 1);
5341   pushlevel (0);
5342   gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
5343   expand_start_bindings (0);
5344
5345   /* Emit the assignments for the elaborations we have to do.  If there
5346      is no destination, this is just a call to execute some statement
5347      that was placed within the declarative region.   But first save a
5348      pointer so we can see if any insns were generated.  */
5349
5350   insn = get_last_insn ();
5351
5352   for (; gnu_elab_list; gnu_elab_list = TREE_CHAIN (gnu_elab_list))
5353     if (TREE_PURPOSE (gnu_elab_list) == NULL_TREE)
5354       {
5355         if (TREE_VALUE (gnu_elab_list) != 0)
5356           expand_expr_stmt (TREE_VALUE (gnu_elab_list));
5357       }
5358     else
5359       {
5360         tree lhs = TREE_PURPOSE (gnu_elab_list);
5361
5362         input_location = DECL_SOURCE_LOCATION (lhs);
5363
5364         /* If LHS has a padded type, convert it to the unpadded type
5365            so the assignment is done properly.  */
5366         if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
5367             && TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
5368           lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
5369
5370         emit_line_note (input_location);
5371         expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
5372                                            TREE_PURPOSE (gnu_elab_list),
5373                                            TREE_VALUE (gnu_elab_list)));
5374       }
5375
5376   /* See if any non-NOTE insns were generated.  */
5377   for (insn = NEXT_INSN (insn); insn; insn = NEXT_INSN (insn))
5378     if (GET_RTX_CLASS (GET_CODE (insn)) == 'i')
5379       {
5380         result = 0;
5381         break;
5382       }
5383
5384   expand_end_bindings (getdecls (), kept_level_p (), -1);
5385   poplevel (kept_level_p (), 1, 0);
5386   gnu_block_stack = TREE_CHAIN (gnu_block_stack);
5387   end_subprog_body ();
5388
5389   /* We are finished with the elaboration list it can now be discarded.  */
5390   gnu_pending_elaboration_lists = TREE_CHAIN (gnu_pending_elaboration_lists);
5391
5392   /* If there were no insns, we don't need an elab routine.  It would
5393      be nice to not output this one, but there's no good way to do that.  */
5394   return result;
5395 }
5396 \f
5397 extern char *__gnat_to_canonical_file_spec (char *);
5398
5399 /* Determine the input_filename and the input_line from the source location
5400    (Sloc) of GNAT_NODE node.  Set the global variable input_filename and
5401    input_line.  If WRITE_NOTE_P is true, emit a line number note.  */
5402
5403 void
5404 set_lineno (Node_Id gnat_node, int write_note_p)
5405 {
5406   Source_Ptr source_location = Sloc (gnat_node);
5407
5408   set_lineno_from_sloc (source_location, write_note_p);
5409 }
5410
5411 /* Likewise, but passed a Sloc.  */
5412
5413 void
5414 set_lineno_from_sloc (Source_Ptr source_location, int write_note_p)
5415 {
5416   /* If node not from source code, ignore.  */
5417   if (source_location < 0)
5418     return;
5419
5420   /* Use the identifier table to make a hashed, permanent copy of the filename,
5421      since the name table gets reallocated after Gigi returns but before all
5422      the debugging information is output. The __gnat_to_canonical_file_spec
5423      call translates filenames from pragmas Source_Reference that contain host
5424      style syntax not understood by gdb. */
5425   input_filename
5426     = IDENTIFIER_POINTER
5427       (get_identifier
5428        (__gnat_to_canonical_file_spec
5429         (Get_Name_String
5430          (Full_Debug_Name (Get_Source_File_Index (source_location))))));
5431
5432   /* ref_filename is the reference file name as given by sinput (i.e no
5433      directory) */
5434   ref_filename
5435     = IDENTIFIER_POINTER
5436       (get_identifier
5437        (Get_Name_String
5438         (Debug_Source_Name (Get_Source_File_Index (source_location)))));;
5439   input_line = Get_Logical_Line_Number (source_location);
5440
5441   if (write_note_p)
5442     emit_line_note (input_location);
5443 }
5444 \f
5445 /* Post an error message.  MSG is the error message, properly annotated.
5446    NODE is the node at which to post the error and the node to use for the
5447    "&" substitution.  */
5448
5449 void
5450 post_error (const char *msg, Node_Id node)
5451 {
5452   String_Template temp;
5453   Fat_Pointer fp;
5454
5455   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5456   fp.Array = msg, fp.Bounds = &temp;
5457   if (Present (node))
5458     Error_Msg_N (fp, node);
5459 }
5460
5461 /* Similar, but NODE is the node at which to post the error and ENT
5462    is the node to use for the "&" substitution.  */
5463
5464 void
5465 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
5466 {
5467   String_Template temp;
5468   Fat_Pointer fp;
5469
5470   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5471   fp.Array = msg, fp.Bounds = &temp;
5472   if (Present (node))
5473     Error_Msg_NE (fp, node, ent);
5474 }
5475
5476 /* Similar, but NODE is the node at which to post the error, ENT is the node
5477    to use for the "&" substitution, and N is the number to use for the ^.  */
5478
5479 void
5480 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
5481 {
5482   String_Template temp;
5483   Fat_Pointer fp;
5484
5485   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5486   fp.Array = msg, fp.Bounds = &temp;
5487   Error_Msg_Uint_1 = UI_From_Int (n);
5488
5489   if (Present (node))
5490     Error_Msg_NE (fp, node, ent);
5491 }
5492 \f
5493 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5494    number to write.  If the tree represents a constant that fits within
5495    a host integer, the text inside curly brackets in MSG will be output
5496    (presumably including a '^').  Otherwise that text will not be output
5497    and the text inside square brackets will be output instead.  */
5498
5499 void
5500 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
5501 {
5502   char *newmsg = alloca (strlen (msg) + 1);
5503   String_Template temp = {1, 0};
5504   Fat_Pointer fp;
5505   char start_yes, end_yes, start_no, end_no;
5506   const char *p;
5507   char *q;
5508
5509   fp.Array = newmsg, fp.Bounds = &temp;
5510
5511   if (host_integerp (t, 1)
5512 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5513       &&
5514       compare_tree_int
5515       (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
5516 #endif
5517       )
5518     {
5519       Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
5520       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
5521     }
5522   else
5523     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
5524
5525   for (p = msg, q = newmsg; *p != 0; p++)
5526     {
5527       if (*p == start_yes)
5528         for (p++; *p != end_yes; p++)
5529           *q++ = *p;
5530       else if (*p == start_no)
5531         for (p++; *p != end_no; p++)
5532           ;
5533       else
5534         *q++ = *p;
5535     }
5536
5537   *q = 0;
5538
5539   temp.High_Bound = strlen (newmsg);
5540   if (Present (node))
5541     Error_Msg_NE (fp, node, ent);
5542 }
5543
5544 /* Similar to post_error_ne_tree, except that NUM is a second
5545    integer to write in the message.  */
5546
5547 void
5548 post_error_ne_tree_2 (const char *msg,
5549                       Node_Id node,
5550                       Entity_Id ent,
5551                       tree t,
5552                       int num)
5553 {
5554   Error_Msg_Uint_2 = UI_From_Int (num);
5555   post_error_ne_tree (msg, node, ent, t);
5556 }
5557
5558 /* Set the node for a second '&' in the error message.  */
5559
5560 void
5561 set_second_error_entity (Entity_Id e)
5562 {
5563   Error_Msg_Node_2 = e;
5564 }
5565 \f
5566 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5567    as the relevant node that provides the location info for the error */
5568
5569 void
5570 gigi_abort (int code)
5571 {
5572   String_Template temp = {1, 10};
5573   Fat_Pointer fp;
5574
5575   fp.Array = "Gigi abort", fp.Bounds = &temp;
5576
5577   Current_Error_Node = error_gnat_node;
5578   Compiler_Abort (fp, code);
5579 }
5580 \f
5581 /* Initialize the table that maps GNAT codes to GCC codes for simple
5582    binary and unary operations.  */
5583
5584 void
5585 init_code_table (void)
5586 {
5587   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
5588   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
5589
5590   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
5591   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
5592   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
5593   gnu_codes[N_Op_Eq] = EQ_EXPR;
5594   gnu_codes[N_Op_Ne] = NE_EXPR;
5595   gnu_codes[N_Op_Lt] = LT_EXPR;
5596   gnu_codes[N_Op_Le] = LE_EXPR;
5597   gnu_codes[N_Op_Gt] = GT_EXPR;
5598   gnu_codes[N_Op_Ge] = GE_EXPR;
5599   gnu_codes[N_Op_Add] = PLUS_EXPR;
5600   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
5601   gnu_codes[N_Op_Multiply] = MULT_EXPR;
5602   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
5603   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
5604   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
5605   gnu_codes[N_Op_Abs] = ABS_EXPR;
5606   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
5607   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
5608   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
5609   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
5610   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
5611   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
5612 }
5613
5614 #include "gt-ada-trans.h"