gcc/ada/trans.c

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