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 = substitute_placeholder_in_expr (gnu_result,
1240                                                                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               gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
1385                                                            gnu_prefix);
1386
1387               break;
1388             }
1389
1390           case Attr_Bit_Position:
1391           case Attr_Position:
1392           case Attr_First_Bit:
1393           case Attr_Last_Bit:
1394           case Attr_Bit:
1395             {
1396               HOST_WIDE_INT bitsize;
1397               HOST_WIDE_INT bitpos;
1398               tree gnu_offset;
1399               tree gnu_field_bitpos;
1400               tree gnu_field_offset;
1401               tree gnu_inner;
1402               enum machine_mode mode;
1403               int unsignedp, volatilep;
1404
1405               gnu_result_type = get_unpadded_type (Etype (gnat_node));
1406               gnu_prefix = remove_conversions (gnu_prefix, 1);
1407               prefix_unused = 1;
1408
1409               /* We can have 'Bit on any object, but if it isn't a
1410                  COMPONENT_REF, the result is zero.  Do not allow
1411                  'Bit on a bare component, though.  */
1412               if (attribute == Attr_Bit
1413                   && TREE_CODE (gnu_prefix) != COMPONENT_REF
1414                   && TREE_CODE (gnu_prefix) != FIELD_DECL)
1415                 {
1416                   gnu_result = integer_zero_node;
1417                   break;
1418                 }
1419
1420               else if (TREE_CODE (gnu_prefix) != COMPONENT_REF
1421                        && ! (attribute == Attr_Bit_Position
1422                              && TREE_CODE (gnu_prefix) == FIELD_DECL))
1423                 gigi_abort (310);
1424
1425               get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1426                                    &mode, &unsignedp, &volatilep);
1427
1428               if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1429                 {
1430                   gnu_field_bitpos
1431                     = bit_position (TREE_OPERAND (gnu_prefix, 1));
1432                   gnu_field_offset
1433                     = byte_position (TREE_OPERAND (gnu_prefix, 1));
1434
1435                   for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1436                        TREE_CODE (gnu_inner) == COMPONENT_REF
1437                        && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1438                        gnu_inner = TREE_OPERAND (gnu_inner, 0))
1439                     {
1440                       gnu_field_bitpos
1441                         = size_binop (PLUS_EXPR, gnu_field_bitpos,
1442                                       bit_position (TREE_OPERAND (gnu_inner,
1443                                                                   1)));
1444                       gnu_field_offset
1445                         = size_binop (PLUS_EXPR, gnu_field_offset,
1446                                       byte_position (TREE_OPERAND (gnu_inner,
1447                                                                    1)));
1448                     }
1449                 }
1450               else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1451                 {
1452                   gnu_field_bitpos = bit_position (gnu_prefix);
1453                   gnu_field_offset = byte_position (gnu_prefix);
1454                 }
1455               else
1456                 {
1457                   gnu_field_bitpos = bitsize_zero_node;
1458                   gnu_field_offset = size_zero_node;
1459                 }
1460
1461               switch (attribute)
1462                 {
1463                 case Attr_Position:
1464                   gnu_result = gnu_field_offset;
1465                   break;
1466
1467                 case Attr_First_Bit:
1468                 case Attr_Bit:
1469                   gnu_result = size_int (bitpos % BITS_PER_UNIT);
1470                   break;
1471
1472                 case Attr_Last_Bit:
1473                   gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1474                   gnu_result
1475                     = size_binop (PLUS_EXPR, gnu_result,
1476                                   TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1477                   gnu_result = size_binop (MINUS_EXPR, gnu_result,
1478                                            bitsize_one_node);
1479                   break;
1480
1481                 case Attr_Bit_Position:
1482                   gnu_result = gnu_field_bitpos;
1483                   break;
1484                 }
1485
1486               /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1487                  we are handling. */
1488               gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
1489                                                            gnu_prefix);
1490
1491               break;
1492             }
1493
1494           case Attr_Min:
1495           case Attr_Max:
1496             gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1497             gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1498
1499             gnu_result_type = get_unpadded_type (Etype (gnat_node));
1500             gnu_result = build_binary_op (attribute == Attr_Min
1501                                           ? MIN_EXPR : MAX_EXPR,
1502                                           gnu_result_type, gnu_lhs, gnu_rhs);
1503             break;
1504
1505           case Attr_Passed_By_Reference:
1506             gnu_result = size_int (default_pass_by_ref (gnu_type)
1507                                    || must_pass_by_ref (gnu_type));
1508             gnu_result_type = get_unpadded_type (Etype (gnat_node));
1509             break;
1510
1511           case Attr_Component_Size:
1512             if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1513                 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1514                     == RECORD_TYPE)
1515                 && (TYPE_IS_PADDING_P
1516                     (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1517               gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1518
1519             gnu_prefix = maybe_implicit_deref (gnu_prefix);
1520             gnu_type = TREE_TYPE (gnu_prefix);
1521
1522             if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1523               gnu_type
1524                 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1525
1526             while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1527                    && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1528               gnu_type = TREE_TYPE (gnu_type);
1529
1530             if (TREE_CODE (gnu_type) != ARRAY_TYPE)
1531               gigi_abort (330);
1532
1533             /* Note this size cannot be self-referential.  */
1534             gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1535             gnu_result_type = get_unpadded_type (Etype (gnat_node));
1536             prefix_unused = 1;
1537             break;
1538
1539           case Attr_Null_Parameter:
1540             /* This is just a zero cast to the pointer type for
1541                our prefix and dereferenced.  */
1542             gnu_result_type = get_unpadded_type (Etype (gnat_node));
1543             gnu_result
1544               = build_unary_op (INDIRECT_REF, NULL_TREE,
1545                                 convert (build_pointer_type (gnu_result_type),
1546                                          integer_zero_node));
1547             TREE_PRIVATE (gnu_result) = 1;
1548             break;
1549
1550           case Attr_Mechanism_Code:
1551             {
1552               int code;
1553               Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1554
1555               prefix_unused = 1;
1556               gnu_result_type = get_unpadded_type (Etype (gnat_node));
1557               if (Present (Expressions (gnat_node)))
1558                 {
1559                   int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1560
1561                   for (gnat_obj = First_Formal (gnat_obj); i > 1;
1562                        i--, gnat_obj = Next_Formal (gnat_obj))
1563                     ;
1564                 }
1565
1566               code = Mechanism (gnat_obj);
1567               if (code == Default)
1568                 code = ((present_gnu_tree (gnat_obj)
1569                          && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1570                              || ((TREE_CODE (get_gnu_tree (gnat_obj))
1571                                   == PARM_DECL)
1572                                  && (DECL_BY_COMPONENT_PTR_P
1573                                      (get_gnu_tree (gnat_obj))))))
1574                         ? By_Reference : By_Copy);
1575               gnu_result = convert (gnu_result_type, size_int (- code));
1576             }
1577           break;
1578
1579           default:
1580             /* Say we have an unimplemented attribute.  Then set the
1581                value to be returned to be a zero and hope that's something
1582                we can convert to the type of this attribute.  */
1583
1584             post_error ("unimplemented attribute", gnat_node);
1585             gnu_result_type = get_unpadded_type (Etype (gnat_node));
1586             gnu_result = integer_zero_node;
1587             break;
1588           }
1589
1590         /* If this is an attribute where the prefix was unused,
1591            force a use of it if it has a side-effect.  But don't do it if
1592            the prefix is just an entity name.  However, if an access check
1593            is needed, we must do it.  See second example in AARM 11.6(5.e). */
1594         if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1595             && ! Is_Entity_Name (Prefix (gnat_node)))
1596           gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1597                                     gnu_prefix, gnu_result));
1598       }
1599       break;
1600
1601     case N_Reference:
1602       /* Like 'Access as far as we are concerned.  */
1603       gnu_result = gnat_to_gnu (Prefix (gnat_node));
1604       gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
1605       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1606       break;
1607
1608     case N_Aggregate:
1609     case N_Extension_Aggregate:
1610       {
1611         tree gnu_aggr_type;
1612
1613         /* ??? It is wrong to evaluate the type now, but there doesn't
1614            seem to be any other practical way of doing it.  */
1615
1616         gnu_aggr_type = gnu_result_type
1617           = get_unpadded_type (Etype (gnat_node));
1618
1619         if (TREE_CODE (gnu_result_type) == RECORD_TYPE
1620             && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
1621           gnu_aggr_type
1622             = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
1623
1624         if (Null_Record_Present (gnat_node))
1625           gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
1626
1627         else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE)
1628           gnu_result
1629             = assoc_to_constructor (First (Component_Associations (gnat_node)),
1630                                     gnu_aggr_type);
1631         else if (TREE_CODE (gnu_aggr_type) == UNION_TYPE)
1632           {
1633             /* The first element is the discrimant, which we ignore.  The
1634                next is the field we're building.  Convert the expression
1635                to the type of the field and then to the union type.  */
1636             Node_Id gnat_assoc
1637               = Next (First (Component_Associations (gnat_node)));
1638             Entity_Id gnat_field = Entity (First (Choices (gnat_assoc)));
1639             tree gnu_field_type
1640               = TREE_TYPE (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0));
1641
1642             gnu_result = convert (gnu_field_type,
1643                                   gnat_to_gnu (Expression (gnat_assoc)));
1644           }
1645         else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
1646           gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
1647                                            gnu_aggr_type,
1648                                            Component_Type (Etype (gnat_node)));
1649         else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
1650           gnu_result
1651             = build_binary_op
1652               (COMPLEX_EXPR, gnu_aggr_type,
1653                gnat_to_gnu (Expression (First
1654                                         (Component_Associations (gnat_node)))),
1655                gnat_to_gnu (Expression
1656                             (Next
1657                              (First (Component_Associations (gnat_node))))));
1658         else
1659           gigi_abort (312);
1660
1661         gnu_result = convert (gnu_result_type, gnu_result);
1662       }
1663       break;
1664
1665     case N_Null:
1666       gnu_result = null_pointer_node;
1667       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1668       break;
1669
1670     case N_Type_Conversion:
1671     case N_Qualified_Expression:
1672       /* Get the operand expression.  */
1673       gnu_result = gnat_to_gnu (Expression (gnat_node));
1674       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1675
1676       gnu_result
1677         = convert_with_check (Etype (gnat_node), gnu_result,
1678                               Do_Overflow_Check (gnat_node),
1679                               Do_Range_Check (Expression (gnat_node)),
1680                               Nkind (gnat_node) == N_Type_Conversion
1681                               && Float_Truncate (gnat_node));
1682       break;
1683
1684     case N_Unchecked_Type_Conversion:
1685       gnu_result = gnat_to_gnu (Expression (gnat_node));
1686       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1687
1688       /* If the result is a pointer type, see if we are improperly
1689          converting to a stricter alignment.  */
1690
1691       if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
1692           && IN (Ekind (Etype (gnat_node)), Access_Kind))
1693         {
1694           unsigned int align = known_alignment (gnu_result);
1695           tree gnu_obj_type = TREE_TYPE (gnu_result_type);
1696           unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
1697
1698           if (align != 0 && align < oalign && ! TYPE_ALIGN_OK (gnu_obj_type))
1699             post_error_ne_tree_2
1700               ("?source alignment (^) < alignment of & (^)",
1701                gnat_node, Designated_Type (Etype (gnat_node)),
1702                size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
1703         }
1704
1705       gnu_result = unchecked_convert (gnu_result_type, gnu_result,
1706                                       No_Truncation (gnat_node));
1707       break;
1708
1709     case N_In:
1710     case N_Not_In:
1711       {
1712         tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
1713         Node_Id gnat_range = Right_Opnd (gnat_node);
1714         tree gnu_low;
1715         tree gnu_high;
1716
1717         /* GNAT_RANGE is either an N_Range node or an identifier
1718            denoting a subtype.  */
1719         if (Nkind (gnat_range) == N_Range)
1720           {
1721             gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
1722             gnu_high = gnat_to_gnu (High_Bound (gnat_range));
1723           }
1724         else if (Nkind (gnat_range) == N_Identifier
1725               || Nkind (gnat_range) == N_Expanded_Name)
1726           {
1727             tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
1728
1729             gnu_low = TYPE_MIN_VALUE (gnu_range_type);
1730             gnu_high = TYPE_MAX_VALUE (gnu_range_type);
1731           }
1732         else
1733           gigi_abort (313);
1734
1735         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1736
1737         /* If LOW and HIGH are identical, perform an equality test.
1738            Otherwise, ensure that GNU_OBJECT is only evaluated once
1739            and perform a full range test.  */
1740         if (operand_equal_p (gnu_low, gnu_high, 0))
1741           gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
1742                                         gnu_object, gnu_low);
1743         else
1744           {
1745             gnu_object = protect_multiple_eval (gnu_object);
1746             gnu_result
1747               = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
1748                                  build_binary_op (GE_EXPR, gnu_result_type,
1749                                                   gnu_object, gnu_low),
1750                                  build_binary_op (LE_EXPR, gnu_result_type,
1751                                                   gnu_object, gnu_high));
1752           }
1753
1754         if (Nkind (gnat_node) == N_Not_In)
1755           gnu_result = invert_truthvalue (gnu_result);
1756       }
1757       break;
1758
1759     case N_Op_Divide:
1760       gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1761       gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1762       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1763       gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
1764                                     ? RDIV_EXPR
1765                                     : (Rounded_Result (gnat_node)
1766                                        ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
1767                                     gnu_result_type, gnu_lhs, gnu_rhs);
1768       break;
1769
1770     case N_And_Then: case N_Or_Else:
1771       {
1772         /* Some processing below (e.g. clear_last_expr) requires access to
1773            status fields now maintained in the current function context, so
1774            we'll setup a dummy one if needed. We cannot use global_binding_p,
1775            since it might be true due to force_global and making a dummy
1776            context would kill the current function context. */
1777         bool make_dummy_context = (cfun == 0);
1778         enum tree_code code = gnu_codes[Nkind (gnat_node)];
1779         tree gnu_rhs_side;
1780
1781         if (make_dummy_context)
1782           init_dummy_function_start ();
1783
1784         /* The elaboration of the RHS may generate code.  If so,
1785            we need to make sure it gets executed after the LHS.  */
1786         gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1787         clear_last_expr ();
1788
1789         gnu_rhs_side = expand_start_stmt_expr (1 /*has_scope*/);
1790         gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1791         expand_end_stmt_expr (gnu_rhs_side);
1792
1793         if (make_dummy_context)
1794           expand_dummy_function_end ();
1795
1796         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1797
1798         if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0)
1799           gnu_rhs = build (COMPOUND_EXPR, gnu_result_type, gnu_rhs_side,
1800                            gnu_rhs);
1801
1802         gnu_result = build_binary_op (code, gnu_result_type, gnu_lhs, gnu_rhs);
1803       }
1804       break;
1805
1806     case N_Op_Or:    case N_Op_And:      case N_Op_Xor:
1807       /* These can either be operations on booleans or on modular types.
1808          Fall through for boolean types since that's the way GNU_CODES is
1809          set up.  */
1810       if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
1811               Modular_Integer_Kind))
1812         {
1813           enum tree_code code
1814             = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
1815                : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
1816                : BIT_XOR_EXPR);
1817
1818           gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1819           gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1820           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1821           gnu_result = build_binary_op (code, gnu_result_type,
1822                                         gnu_lhs, gnu_rhs);
1823           break;
1824         }
1825
1826       /* ... fall through ... */
1827
1828     case N_Op_Eq:    case N_Op_Ne:       case N_Op_Lt:
1829     case N_Op_Le:    case N_Op_Gt:       case N_Op_Ge:
1830     case N_Op_Add:   case N_Op_Subtract: case N_Op_Multiply:
1831     case N_Op_Mod:   case N_Op_Rem:
1832     case N_Op_Rotate_Left:
1833     case N_Op_Rotate_Right:
1834     case N_Op_Shift_Left:
1835     case N_Op_Shift_Right:
1836     case N_Op_Shift_Right_Arithmetic:
1837       {
1838         enum tree_code code = gnu_codes[Nkind (gnat_node)];
1839         tree gnu_type;
1840
1841         gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1842         gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1843         gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
1844
1845         /* If this is a comparison operator, convert any references to
1846            an unconstrained array value into a reference to the
1847            actual array.  */
1848         if (TREE_CODE_CLASS (code) == '<')
1849           {
1850             gnu_lhs = maybe_unconstrained_array (gnu_lhs);
1851             gnu_rhs = maybe_unconstrained_array (gnu_rhs);
1852           }
1853
1854         /* If the result type is a private type, its full view may be a
1855            numeric subtype. The representation we need is that of its base
1856            type, given that it is the result of an arithmetic operation.  */
1857         else if (Is_Private_Type (Etype (gnat_node)))
1858           gnu_type = gnu_result_type
1859             = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
1860
1861         /* If this is a shift whose count is not guaranteed to be correct,
1862            we need to adjust the shift count.  */
1863         if (IN (Nkind (gnat_node), N_Op_Shift)
1864             && ! Shift_Count_OK (gnat_node))
1865           {
1866             tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
1867             tree gnu_max_shift
1868               = convert (gnu_count_type, TYPE_SIZE (gnu_type));
1869
1870             if (Nkind (gnat_node) == N_Op_Rotate_Left
1871                 || Nkind (gnat_node) == N_Op_Rotate_Right)
1872               gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
1873                                          gnu_rhs, gnu_max_shift);
1874             else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
1875               gnu_rhs
1876                 = build_binary_op
1877                   (MIN_EXPR, gnu_count_type,
1878                    build_binary_op (MINUS_EXPR,
1879                                     gnu_count_type,
1880                                     gnu_max_shift,
1881                                     convert (gnu_count_type,
1882                                              integer_one_node)),
1883                    gnu_rhs);
1884           }
1885
1886         /* For right shifts, the type says what kind of shift to do,
1887            so we may need to choose a different type.  */
1888         if (Nkind (gnat_node) == N_Op_Shift_Right
1889             && ! TREE_UNSIGNED (gnu_type))
1890           gnu_type = gnat_unsigned_type (gnu_type);
1891         else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
1892                  && TREE_UNSIGNED (gnu_type))
1893           gnu_type = gnat_signed_type (gnu_type);
1894
1895         if (gnu_type != gnu_result_type)
1896           {
1897             gnu_lhs = convert (gnu_type, gnu_lhs);
1898             gnu_rhs = convert (gnu_type, gnu_rhs);
1899           }
1900
1901         gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
1902
1903         /* If this is a logical shift with the shift count not verified,
1904            we must return zero if it is too large.  We cannot compensate
1905            above in this case.  */
1906         if ((Nkind (gnat_node) == N_Op_Shift_Left
1907              || Nkind (gnat_node) == N_Op_Shift_Right)
1908             && ! Shift_Count_OK (gnat_node))
1909           gnu_result
1910             = build_cond_expr
1911               (gnu_type,
1912                build_binary_op (GE_EXPR, integer_type_node,
1913                                 gnu_rhs,
1914                                 convert (TREE_TYPE (gnu_rhs),
1915                                          TYPE_SIZE (gnu_type))),
1916                convert (gnu_type, integer_zero_node),
1917                gnu_result);
1918       }
1919       break;
1920
1921     case N_Conditional_Expression:
1922       {
1923         tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
1924         tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1925         tree gnu_false
1926           = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
1927
1928         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1929         gnu_result = build_cond_expr (gnu_result_type,
1930                                       gnat_truthvalue_conversion (gnu_cond),
1931                                       gnu_true, gnu_false);
1932       }
1933       break;
1934
1935     case N_Op_Plus:
1936       gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
1937       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1938       break;
1939
1940     case N_Op_Not:
1941       /* This case can apply to a boolean or a modular type.
1942          Fall through for a boolean operand since GNU_CODES is set
1943          up to handle this.  */
1944       if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
1945         {
1946           gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
1947           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1948           gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
1949                                        gnu_expr);
1950           break;
1951         }
1952
1953       /* ... fall through ... */
1954
1955     case N_Op_Minus:  case N_Op_Abs:
1956       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
1957
1958       if (Ekind (Etype (gnat_node)) != E_Private_Type)
1959          gnu_result_type = get_unpadded_type (Etype (gnat_node));
1960       else
1961          gnu_result_type = get_unpadded_type (Base_Type
1962                                               (Full_View (Etype (gnat_node))));
1963
1964       gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
1965                                    gnu_result_type, gnu_expr);
1966       break;
1967
1968     case N_Allocator:
1969       {
1970         tree gnu_init = 0;
1971         tree gnu_type;
1972
1973         gnat_temp = Expression (gnat_node);
1974
1975         /* The Expression operand can either be an N_Identifier or
1976            Expanded_Name, which must represent a type, or a
1977            N_Qualified_Expression, which contains both the object type and an
1978            initial value for the object.  */
1979         if (Nkind (gnat_temp) == N_Identifier
1980             || Nkind (gnat_temp) == N_Expanded_Name)
1981           gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
1982         else if (Nkind (gnat_temp) == N_Qualified_Expression)
1983           {
1984             Entity_Id gnat_desig_type
1985               = Designated_Type (Underlying_Type (Etype (gnat_node)));
1986
1987             gnu_init = gnat_to_gnu (Expression (gnat_temp));
1988
1989             gnu_init = maybe_unconstrained_array (gnu_init);
1990             if (Do_Range_Check (Expression (gnat_temp)))
1991               gnu_init = emit_range_check (gnu_init, gnat_desig_type);
1992
1993             if (Is_Elementary_Type (gnat_desig_type)
1994                 || Is_Constrained (gnat_desig_type))
1995               {
1996                 gnu_type = gnat_to_gnu_type (gnat_desig_type);
1997                 gnu_init = convert (gnu_type, gnu_init);
1998               }
1999             else
2000               {
2001                 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
2002                 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2003                   gnu_type = TREE_TYPE (gnu_init);
2004
2005                 gnu_init = convert (gnu_type, gnu_init);
2006               }
2007           }
2008         else
2009           gigi_abort (315);
2010
2011         gnu_result_type = get_unpadded_type (Etype (gnat_node));
2012         return build_allocator (gnu_type, gnu_init, gnu_result_type,
2013                                 Procedure_To_Call (gnat_node),
2014                                 Storage_Pool (gnat_node), gnat_node);
2015       }
2016       break;
2017
2018     /***************************/
2019     /* Chapter 5: Statements:  */
2020     /***************************/
2021
2022     case N_Label:
2023       if (! type_annotate_only)
2024         {
2025           tree gnu_label = gnat_to_gnu (Identifier (gnat_node));
2026           Node_Id gnat_parent = Parent (gnat_node);
2027
2028           expand_label (gnu_label);
2029
2030           /* If this is the first label of an exception handler, we must
2031              mark that any CALL_INSN can jump to it.  */
2032           if (Present (gnat_parent)
2033               && Nkind (gnat_parent) == N_Exception_Handler
2034               && First (Statements (gnat_parent)) == gnat_node)
2035             nonlocal_goto_handler_labels
2036               = gen_rtx_EXPR_LIST (VOIDmode, label_rtx (gnu_label),
2037                                    nonlocal_goto_handler_labels);
2038         }
2039       break;
2040
2041     case N_Null_Statement:
2042       break;
2043
2044     case N_Assignment_Statement:
2045       if (type_annotate_only)
2046         break;
2047
2048       /* Get the LHS and RHS of the statement and convert any reference to an
2049          unconstrained array into a reference to the underlying array.  */
2050       gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
2051       gnu_rhs
2052         = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
2053
2054       /* If range check is needed, emit code to generate it */
2055       if (Do_Range_Check (Expression (gnat_node)))
2056         gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
2057
2058       /* If either side's type has a size that overflows, convert this
2059          into raise of Storage_Error: execution shouldn't have gotten
2060          here anyway.  */
2061       if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
2062            && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
2063           || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
2064               && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
2065         gnu_result = build_call_raise (SE_Object_Too_Large);
2066       else
2067         gnu_result
2068           = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
2069
2070       gnu_result = build_nt (EXPR_STMT, gnu_result);
2071       break;
2072
2073     case N_If_Statement:
2074       /* Start an IF statement giving the condition.  */
2075       gnu_expr = gnat_to_gnu (Condition (gnat_node));
2076       set_lineno (gnat_node, 1);
2077       expand_start_cond (gnu_expr, 0);
2078
2079       /* Generate code for the statements to be executed if the condition
2080          is true.  */
2081
2082       for (gnat_temp = First (Then_Statements (gnat_node));
2083            Present (gnat_temp);
2084            gnat_temp = Next (gnat_temp))
2085         gnat_to_code (gnat_temp);
2086
2087       /* Generate each of the "else if" parts.  */
2088       if (Present (Elsif_Parts (gnat_node)))
2089         {
2090           for (gnat_temp = First (Elsif_Parts (gnat_node));
2091                Present (gnat_temp);
2092                gnat_temp = Next (gnat_temp))
2093             {
2094               Node_Id gnat_statement;
2095
2096               expand_start_else ();
2097
2098               /* Set up the line numbers for each condition we test.  */
2099               set_lineno (Condition (gnat_temp), 1);
2100               expand_elseif (gnat_to_gnu (Condition (gnat_temp)));
2101
2102               for (gnat_statement = First (Then_Statements (gnat_temp));
2103                    Present (gnat_statement);
2104                    gnat_statement = Next (gnat_statement))
2105                 gnat_to_code (gnat_statement);
2106             }
2107         }
2108
2109       /* Finally, handle any statements in the "else" part.  */
2110       if (Present (Else_Statements (gnat_node)))
2111         {
2112           expand_start_else ();
2113
2114           for (gnat_temp = First (Else_Statements (gnat_node));
2115                Present (gnat_temp);
2116                gnat_temp = Next (gnat_temp))
2117             gnat_to_code (gnat_temp);
2118         }
2119
2120       expand_end_cond ();
2121       break;
2122
2123     case N_Case_Statement:
2124       {
2125         Node_Id gnat_when;
2126         Node_Id gnat_choice;
2127         tree gnu_label;
2128         Node_Id gnat_statement;
2129
2130         gnu_expr = gnat_to_gnu (Expression (gnat_node));
2131         gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2132
2133         /*  The range of values in a case statement is determined by the
2134             rules in RM 5.4(7-9). In almost all cases, this range is
2135             represented by the Etype of the expression. One exception arises
2136             in the case of a simple name that is parenthesized. This still
2137             has the Etype of the name, but since it is not a name, para 7
2138             does not apply, and we need to go to the base type. This is the
2139             only case where parenthesization affects the dynamic semantics
2140             (i.e. the range of possible values at runtime that is covered by
2141             the others alternative.
2142
2143             Another exception is if the subtype of the expression is
2144             non-static.  In that case, we also have to use the base type.  */
2145         if (Paren_Count (Expression (gnat_node)) != 0
2146             || !Is_OK_Static_Subtype (Underlying_Type
2147                                       (Etype (Expression (gnat_node)))))
2148           gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2149
2150         set_lineno (gnat_node, 1);
2151         expand_start_case (1, gnu_expr, TREE_TYPE (gnu_expr), "case");
2152
2153         for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2154              Present (gnat_when);
2155              gnat_when = Next_Non_Pragma (gnat_when))
2156           {
2157             /* First compile all the different case choices for the  current
2158                WHEN alternative.  */
2159
2160             for (gnat_choice = First (Discrete_Choices (gnat_when));
2161                  Present (gnat_choice); gnat_choice = Next (gnat_choice))
2162               {
2163                 int error_code;
2164
2165                 gnu_label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2166
2167                 set_lineno (gnat_choice, 1);
2168                 switch (Nkind (gnat_choice))
2169                   {
2170                   case N_Range:
2171                     /* Abort on all errors except range empty, which
2172                        means we ignore this alternative.  */
2173                     error_code
2174                       = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice)),
2175                                         gnat_to_gnu (High_Bound (gnat_choice)),
2176                                         convert, gnu_label, 0);
2177
2178                     if (error_code != 0 && error_code != 4)
2179                       gigi_abort (332);
2180                     break;
2181
2182                   case N_Subtype_Indication:
2183                     error_code
2184                       = pushcase_range
2185                         (gnat_to_gnu (Low_Bound (Range_Expression
2186                                                  (Constraint (gnat_choice)))),
2187                          gnat_to_gnu (High_Bound (Range_Expression
2188                                                   (Constraint (gnat_choice)))),
2189                          convert, gnu_label, 0);
2190
2191                     if (error_code != 0 && error_code != 4)
2192                       gigi_abort (332);
2193                     break;
2194
2195                   case N_Identifier:
2196                   case N_Expanded_Name:
2197                     /* This represents either a subtype range or a static value
2198                        of some kind; Ekind says which.  If a static value,
2199                        fall through to the next case.  */
2200                     if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2201                       {
2202                         tree type = get_unpadded_type (Entity (gnat_choice));
2203
2204                         error_code
2205                           = pushcase_range (fold (TYPE_MIN_VALUE (type)),
2206                                             fold (TYPE_MAX_VALUE (type)),
2207                                             convert, gnu_label, 0);
2208
2209                         if (error_code != 0 && error_code != 4)
2210                           gigi_abort (332);
2211                         break;
2212                       }
2213                     /* ... fall through ... */
2214                   case N_Character_Literal:
2215                   case N_Integer_Literal:
2216                     if (pushcase (gnat_to_gnu (gnat_choice), convert,
2217                                   gnu_label, 0))
2218                       gigi_abort (332);
2219                     break;
2220
2221                   case N_Others_Choice:
2222                     if (pushcase (NULL_TREE, convert, gnu_label, 0))
2223                       gigi_abort (332);
2224                     break;
2225
2226                   default:
2227                     gigi_abort (316);
2228                   }
2229               }
2230
2231             /* After compiling the choices attached to the WHEN compile the
2232                body of statements that have to be executed, should the
2233                "WHEN ... =>" be taken.  Push a binding level here in case
2234                variables are declared since we want them to be local to this
2235                set of statements instead of the block containing the Case
2236                statement.  */
2237             pushlevel (0);
2238             expand_start_bindings (0);
2239             for (gnat_statement = First (Statements (gnat_when));
2240                  Present (gnat_statement);
2241                  gnat_statement = Next (gnat_statement))
2242               gnat_to_code (gnat_statement);
2243
2244             /* Communicate to GCC that we are done with the current WHEN,
2245                i.e. insert a "break" statement.  */
2246             expand_exit_something ();
2247             expand_end_bindings (getdecls (), kept_level_p (), -1);
2248             poplevel (kept_level_p (), 1, 0);
2249           }
2250
2251         expand_end_case (gnu_expr);
2252       }
2253       break;
2254
2255     case N_Loop_Statement:
2256       {
2257         /* The loop variable in GCC form, if any. */
2258         tree gnu_loop_var = NULL_TREE;
2259         /* PREINCREMENT_EXPR or PREDECREMENT_EXPR.  */
2260         enum tree_code gnu_update = ERROR_MARK;
2261         /* Used if this is a named loop for so EXIT can work.  */
2262         struct nesting *loop_id;
2263         /* Condition to continue loop tested at top of loop.  */
2264         tree gnu_top_condition = integer_one_node;
2265         /* Similar, but tested at bottom of loop.  */
2266         tree gnu_bottom_condition = integer_one_node;
2267         Node_Id gnat_statement;
2268         Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2269         Node_Id gnat_top_condition = Empty;
2270         int enclosing_if_p = 0;
2271
2272         /* Set the condition that under which the loop should continue.
2273            For "LOOP .... END LOOP;" the condition is always true.  */
2274         if (No (gnat_iter_scheme))
2275           ;
2276         /* The case "WHILE condition LOOP ..... END LOOP;" */
2277         else if (Present (Condition (gnat_iter_scheme)))
2278           gnat_top_condition = Condition (gnat_iter_scheme);
2279         else
2280           {
2281             /* We have an iteration scheme.  */
2282             Node_Id gnat_loop_spec
2283               = Loop_Parameter_Specification (gnat_iter_scheme);
2284             Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2285             Entity_Id gnat_type = Etype (gnat_loop_var);
2286             tree gnu_type = get_unpadded_type (gnat_type);
2287             tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2288             tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2289             int reversep = Reverse_Present (gnat_loop_spec);
2290             tree gnu_first = reversep ? gnu_high : gnu_low;
2291             tree gnu_last = reversep ? gnu_low : gnu_high;
2292             enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
2293             tree gnu_base_type = get_base_type (gnu_type);
2294             tree gnu_limit
2295               = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
2296                  : TYPE_MAX_VALUE (gnu_base_type));
2297
2298             /* We know the loop variable will not overflow if GNU_LAST is
2299                a constant and is not equal to GNU_LIMIT.  If it might
2300                overflow, we have to move the limit test to the end of
2301                the loop.  In that case, we have to test for an
2302                empty loop outside the loop.  */
2303             if (TREE_CODE (gnu_last) != INTEGER_CST
2304                 || TREE_CODE (gnu_limit) != INTEGER_CST
2305                 || tree_int_cst_equal (gnu_last, gnu_limit))
2306               {
2307                 gnu_expr = build_binary_op (LE_EXPR, integer_type_node,
2308                                             gnu_low, gnu_high);
2309                 set_lineno (gnat_loop_spec, 1);
2310                 expand_start_cond (gnu_expr, 0);
2311                 enclosing_if_p = 1;
2312               }
2313
2314             /* Open a new nesting level that will surround the loop to declare
2315                the loop index variable.  */
2316             pushlevel (0);
2317             expand_start_bindings (0);
2318
2319             /* Declare the loop index and set it to its initial value.  */
2320             gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2321             if (DECL_BY_REF_P (gnu_loop_var))
2322               gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE,
2323                                              gnu_loop_var);
2324
2325             /* The loop variable might be a padded type, so use `convert' to
2326                get a reference to the inner variable if so.  */
2327             gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
2328
2329             /* Set either the top or bottom exit condition as
2330                appropriate depending on whether we know an overflow
2331                cannot occur or not. */
2332             if (enclosing_if_p)
2333               gnu_bottom_condition
2334                 = build_binary_op (NE_EXPR, integer_type_node,
2335                                    gnu_loop_var, gnu_last);
2336             else
2337               gnu_top_condition
2338                 = build_binary_op (end_code, integer_type_node,
2339                                    gnu_loop_var, gnu_last);
2340
2341             gnu_update = reversep ? PREDECREMENT_EXPR : PREINCREMENT_EXPR;
2342           }
2343
2344         set_lineno (gnat_node, 1);
2345         if (gnu_loop_var)
2346           loop_id = expand_start_loop_continue_elsewhere (1);
2347         else
2348           loop_id = expand_start_loop (1);
2349
2350         /* If the loop was named, have the name point to this loop.  In this
2351            case, the association is not a ..._DECL node; in fact, it isn't
2352            a GCC tree node at all.  Since this name is referenced inside
2353            the loop, do it before we process the statements of the loop.  */
2354         if (Present (Identifier (gnat_node)))
2355           {
2356             tree gnu_loop_id = make_node (GNAT_LOOP_ID);
2357
2358             TREE_LOOP_ID (gnu_loop_id) = loop_id;
2359             save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_id, 1);
2360           }
2361
2362         set_lineno (gnat_node, 1);
2363
2364         /* We must evaluate the condition after we've entered the
2365            loop so that any expression actions get done in the right
2366            place.  */
2367         if (Present (gnat_top_condition))
2368           gnu_top_condition = gnat_to_gnu (gnat_top_condition);
2369
2370         expand_exit_loop_top_cond (0, gnu_top_condition);
2371
2372         /* Make the loop body into its own block, so any allocated
2373            storage will be released every iteration.  This is needed
2374            for stack allocation.  */
2375
2376         pushlevel (0);
2377         gnu_block_stack
2378           = tree_cons (gnu_bottom_condition, NULL_TREE, gnu_block_stack);
2379         expand_start_bindings (0);
2380
2381         for (gnat_statement = First (Statements (gnat_node));
2382              Present (gnat_statement);
2383              gnat_statement = Next (gnat_statement))
2384           gnat_to_code (gnat_statement);
2385
2386         expand_end_bindings (getdecls (), kept_level_p (), -1);
2387         poplevel (kept_level_p (), 1, 0);
2388         gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2389
2390         set_lineno (gnat_node, 1);
2391         expand_exit_loop_if_false (0, gnu_bottom_condition);
2392
2393         if (gnu_loop_var)
2394           {
2395             expand_loop_continue_here ();
2396             gnu_expr = build_binary_op (gnu_update, TREE_TYPE (gnu_loop_var),
2397                                         gnu_loop_var,
2398                                         convert (TREE_TYPE (gnu_loop_var),
2399                                                  integer_one_node));
2400             set_lineno (gnat_iter_scheme, 1);
2401             expand_expr_stmt (gnu_expr);
2402           }
2403
2404         set_lineno (gnat_node, 1);
2405         expand_end_loop ();
2406
2407         if (gnu_loop_var)
2408           {
2409             /* Close the nesting level that sourround the loop that was used to
2410                declare the loop index variable.   */
2411             set_lineno (gnat_node, 1);
2412             expand_end_bindings (getdecls (), 1, -1);
2413             poplevel (1, 1, 0);
2414           }
2415
2416         if (enclosing_if_p)
2417           {
2418             set_lineno (gnat_node, 1);
2419             expand_end_cond ();
2420           }
2421       }
2422       break;
2423
2424     case N_Block_Statement:
2425       pushlevel (0);
2426       gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
2427       expand_start_bindings (0);
2428       process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
2429       gnat_to_code (Handled_Statement_Sequence (gnat_node));
2430       expand_end_bindings (getdecls (), kept_level_p (), -1);
2431       poplevel (kept_level_p (), 1, 0);
2432       gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2433       if (Present (Identifier (gnat_node)))
2434         mark_out_of_scope (Entity (Identifier (gnat_node)));
2435       break;
2436
2437     case N_Exit_Statement:
2438       {
2439         /* Which loop to exit, NULL if the current loop.   */
2440         struct nesting *loop_id = 0;
2441         /* The GCC version of the optional GNAT condition node attached to the
2442            exit statement. Exit the loop if this is false.  */
2443         tree gnu_cond = integer_zero_node;
2444
2445         if (Present (Name (gnat_node)))
2446           loop_id
2447             = TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node))));
2448
2449         if (Present (Condition (gnat_node)))
2450           gnu_cond = invert_truthvalue (gnat_truthvalue_conversion
2451                                         (gnat_to_gnu (Condition (gnat_node))));
2452
2453         set_lineno (gnat_node, 1);
2454         expand_exit_loop_if_false (loop_id, gnu_cond);
2455       }
2456       break;
2457
2458     case N_Return_Statement:
2459       if (type_annotate_only)
2460         break;
2461
2462       {
2463         /* The gnu function type of the subprogram currently processed.  */
2464         tree gnu_subprog_type = TREE_TYPE (current_function_decl);
2465         /* The return value from the subprogram.  */
2466         tree gnu_ret_val = 0;
2467
2468         /* If we are dealing with a "return;" from an Ada procedure with
2469            parameters passed by copy in copy out, we need to return a record
2470            containing the final values of these parameters.  If the list
2471            contains only one entry, return just that entry.
2472
2473            For a full description of the copy in copy out parameter mechanism,
2474            see the part of the gnat_to_gnu_entity routine dealing with the
2475            translation of subprograms.
2476
2477            But if we have a return label defined, convert this into
2478            a branch to that label.  */
2479
2480         if (TREE_VALUE (gnu_return_label_stack) != 0)
2481           expand_goto (TREE_VALUE (gnu_return_label_stack));
2482
2483         else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
2484           {
2485             if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
2486               gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
2487             else
2488               gnu_ret_val
2489                 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2490                                      TYPE_CI_CO_LIST (gnu_subprog_type));
2491           }
2492
2493         /* If the Ada subprogram is a function, we just need to return the
2494            expression.   If the subprogram returns an unconstrained
2495            array, we have to allocate a new version of the result and
2496            return it.  If we return by reference, return a pointer.  */
2497
2498         else if (Present (Expression (gnat_node)))
2499           {
2500             gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
2501
2502             /* Do not remove the padding from GNU_RET_VAL if the inner
2503                type is self-referential since we want to allocate the fixed
2504                size in that case.  */
2505             if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
2506                 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
2507                     == RECORD_TYPE)
2508                 && (TYPE_IS_PADDING_P
2509                     (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
2510                 && (CONTAINS_PLACEHOLDER_P
2511                     (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
2512               gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
2513
2514             if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
2515                 || By_Ref (gnat_node))
2516               gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
2517
2518             else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
2519               {
2520                 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
2521
2522                 /* We have two cases: either the function returns with
2523                    depressed stack or not.  If not, we allocate on the
2524                    secondary stack.  If so, we allocate in the stack frame.
2525                    if no copy is needed, the front end will set By_Ref,
2526                    which we handle in the case above.  */
2527                 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
2528                   gnu_ret_val
2529                     = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
2530                                        TREE_TYPE (gnu_subprog_type), 0, -1,
2531                                        gnat_node);
2532                 else
2533                   gnu_ret_val
2534                     = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
2535                                        TREE_TYPE (gnu_subprog_type),
2536                                        Procedure_To_Call (gnat_node),
2537                                        Storage_Pool (gnat_node), gnat_node);
2538               }
2539           }
2540
2541         set_lineno (gnat_node, 1);
2542         if (gnu_ret_val)
2543           expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
2544                                           DECL_RESULT (current_function_decl),
2545                                           gnu_ret_val));
2546         else
2547           expand_null_return ();
2548
2549       }
2550       break;
2551
2552     case N_Goto_Statement:
2553       if (type_annotate_only)
2554         break;
2555
2556       gnu_expr = gnat_to_gnu (Name (gnat_node));
2557       TREE_USED (gnu_expr) = 1;
2558       set_lineno (gnat_node, 1);
2559       expand_goto (gnu_expr);
2560       break;
2561
2562     /****************************/
2563     /* Chapter 6: Subprograms:  */
2564     /****************************/
2565
2566     case N_Subprogram_Declaration:
2567       /* Unless there is a freeze node, declare the subprogram.  We consider
2568          this a "definition" even though we're not generating code for
2569          the subprogram because we will be making the corresponding GCC
2570          node here.  */
2571
2572       if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
2573         gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
2574                             NULL_TREE, 1);
2575
2576       break;
2577
2578     case N_Abstract_Subprogram_Declaration:
2579       /* This subprogram doesn't exist for code generation purposes, but we
2580          have to elaborate the types of any parameters, unless they are
2581          imported types (nothing to generate in this case).  */
2582       for (gnat_temp
2583            = First_Formal (Defining_Entity (Specification (gnat_node)));
2584            Present (gnat_temp);
2585            gnat_temp = Next_Formal_With_Extras (gnat_temp))
2586         if (Is_Itype (Etype (gnat_temp))
2587             && !From_With_Type (Etype (gnat_temp)))
2588           gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2589
2590       break;
2591
2592     case N_Defining_Program_Unit_Name:
2593       /* For a child unit identifier go up a level to get the
2594          specificaton.  We get this when we try to find the spec of
2595          a child unit package that is the compilation unit being compiled. */
2596       gnat_to_code (Parent (gnat_node));
2597       break;
2598
2599     case N_Subprogram_Body:
2600       {
2601         /* Save debug output mode in case it is reset.  */
2602         enum debug_info_type save_write_symbols = write_symbols;
2603         const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks;
2604         /* Definining identifier of a parameter to the subprogram.  */
2605         Entity_Id gnat_param;
2606         /* The defining identifier for the subprogram body. Note that if a
2607            specification has appeared before for this body, then the identifier
2608            occurring in that specification will also be a defining identifier
2609            and all the calls to this subprogram will point to that
2610            specification.  */
2611         Entity_Id gnat_subprog_id
2612           = (Present (Corresponding_Spec (gnat_node))
2613              ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2614
2615         /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
2616         tree gnu_subprog_decl;
2617         /* The FUNCTION_TYPE node corresponding to the subprogram spec.  */
2618         tree gnu_subprog_type;
2619         tree gnu_cico_list;
2620
2621         /* If this is a generic object or if it has been eliminated,
2622            ignore it.  */
2623
2624         if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2625             || Ekind (gnat_subprog_id) == E_Generic_Function
2626             || Is_Eliminated (gnat_subprog_id))
2627           break;
2628
2629         /* If debug information is suppressed for the subprogram,
2630            turn debug mode off for the duration of processing.  */
2631         if (!Needs_Debug_Info (gnat_subprog_id))
2632           {
2633             write_symbols = NO_DEBUG;
2634             debug_hooks = &do_nothing_debug_hooks;
2635           }
2636
2637         /* If this subprogram acts as its own spec, define it.  Otherwise,
2638            just get the already-elaborated tree node.  However, if this
2639            subprogram had its elaboration deferred, we will already have
2640            made a tree node for it.  So treat it as not being defined in
2641            that case.  Such a subprogram cannot have an address clause or
2642            a freeze node, so this test is safe, though it does disable
2643            some otherwise-useful error checking.  */
2644         gnu_subprog_decl
2645           = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2646                                 Acts_As_Spec (gnat_node)
2647                                 && ! present_gnu_tree (gnat_subprog_id));
2648
2649         gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2650
2651         /* Set the line number in the decl to correspond to that of
2652            the body so that the line number notes are written
2653            correctly.  */
2654         set_lineno (gnat_node, 0);
2655         DECL_SOURCE_LOCATION (gnu_subprog_decl) = input_location;
2656
2657         begin_subprog_body (gnu_subprog_decl);
2658
2659         /* There used to be a second call to set_lineno here, with
2660            write_note_p set, but begin_subprog_body actually already emits the
2661            note we want (via init_function_start).
2662
2663            Emitting a second note here was necessary for -ftest-coverage with
2664            GCC 2.8.1, as the first one was skipped by branch_prob. This is no
2665            longer the case with GCC 3.x, so emitting a second note here would
2666            result in having the first line of the subprogram counted twice by
2667            gcov.  */
2668
2669         pushlevel (0);
2670         gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
2671         expand_start_bindings (0);
2672
2673         gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2674
2675         /* If there are OUT parameters, we need to ensure that the
2676            return statement properly copies them out.  We do this by
2677            making a new block and converting any inner return into a goto
2678            to a label at the end of the block.  */
2679
2680         if (gnu_cico_list != 0)
2681           {
2682             gnu_return_label_stack
2683               = tree_cons (NULL_TREE,
2684                            build_decl (LABEL_DECL, NULL_TREE, NULL_TREE),
2685                            gnu_return_label_stack);
2686             pushlevel (0);
2687             expand_start_bindings (0);
2688           }
2689         else
2690           gnu_return_label_stack
2691             = tree_cons (NULL_TREE, NULL_TREE, gnu_return_label_stack);
2692
2693         /* See if there are any parameters for which we don't yet have
2694            GCC entities.  These must be for OUT parameters for which we
2695            will be making VAR_DECL nodes here.  Fill them in to
2696            TYPE_CI_CO_LIST, which must contain the empty entry as well.
2697            We can match up the entries because TYPE_CI_CO_LIST is in the
2698            order of the parameters.  */
2699
2700         for (gnat_param = First_Formal (gnat_subprog_id);
2701              Present (gnat_param);
2702              gnat_param = Next_Formal_With_Extras (gnat_param))
2703           if (present_gnu_tree (gnat_param))
2704             adjust_decl_rtl (get_gnu_tree (gnat_param));
2705           else
2706             {
2707               /* Skip any entries that have been already filled in; they
2708                  must correspond to IN OUT parameters.  */
2709             for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0;
2710                  gnu_cico_list = TREE_CHAIN (gnu_cico_list))
2711               ;
2712
2713             /* Do any needed references for padded types.  */
2714             TREE_VALUE (gnu_cico_list)
2715               = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
2716                          gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2717           }
2718
2719         process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
2720
2721         /* Generate the code of the subprogram itself.  A return statement
2722            will be present and any OUT parameters will be handled there.  */
2723         gnat_to_code (Handled_Statement_Sequence (gnat_node));
2724
2725         expand_end_bindings (getdecls (), kept_level_p (), -1);
2726         poplevel (kept_level_p (), 1, 0);
2727         gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2728
2729         if (TREE_VALUE (gnu_return_label_stack) != 0)
2730           {
2731             tree gnu_retval;
2732
2733             expand_end_bindings (NULL_TREE, kept_level_p (), -1);
2734             poplevel (kept_level_p (), 1, 0);
2735             expand_label (TREE_VALUE (gnu_return_label_stack));
2736
2737             gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2738             set_lineno (gnat_node, 1);
2739             if (list_length (gnu_cico_list) == 1)
2740               gnu_retval = TREE_VALUE (gnu_cico_list);
2741             else
2742                gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2743                                                gnu_cico_list);
2744
2745             if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
2746               gnu_retval
2747                 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
2748
2749             expand_return
2750               (build_binary_op (MODIFY_EXPR, NULL_TREE,
2751                                 DECL_RESULT (current_function_decl),
2752                                 gnu_retval));
2753
2754           }
2755
2756         gnu_return_label_stack = TREE_CHAIN (gnu_return_label_stack);
2757
2758         /* Disconnect the trees for parameters that we made variables for
2759            from the GNAT entities since these will become unusable after
2760            we end the function.  */
2761         for (gnat_param = First_Formal (gnat_subprog_id);
2762              Present (gnat_param);
2763              gnat_param = Next_Formal_With_Extras (gnat_param))
2764           if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
2765             save_gnu_tree (gnat_param, NULL_TREE, 0);
2766
2767         end_subprog_body ();
2768         mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2769         write_symbols = save_write_symbols;
2770         debug_hooks = save_debug_hooks;
2771       }
2772       break;
2773
2774     case N_Function_Call:
2775     case N_Procedure_Call_Statement:
2776
2777       if (type_annotate_only)
2778         break;
2779
2780       {
2781         /* The GCC node corresponding to the GNAT subprogram name.  This can
2782            either be a FUNCTION_DECL node if we are dealing with a standard
2783            subprogram call, or an indirect reference expression (an
2784            INDIRECT_REF node) pointing to a subprogram.  */
2785         tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
2786         /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2787         tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
2788         tree gnu_subprog_addr
2789           = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node);
2790         Entity_Id gnat_formal;
2791         Node_Id gnat_actual;
2792         tree gnu_actual_list = NULL_TREE;
2793         tree gnu_name_list = NULL_TREE;
2794         tree gnu_after_list = NULL_TREE;
2795         tree gnu_subprog_call;
2796
2797         switch (Nkind (Name (gnat_node)))
2798           {
2799           case N_Identifier:
2800           case N_Operator_Symbol:
2801           case N_Expanded_Name:
2802           case N_Attribute_Reference:
2803             if (Is_Eliminated (Entity (Name (gnat_node))))
2804               Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
2805           }
2806
2807         if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE)
2808           gigi_abort (317);
2809
2810         /* If we are calling a stubbed function, make this into a
2811            raise of Program_Error.  Elaborate all our args first.  */
2812
2813         if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
2814             && DECL_STUBBED_P (gnu_subprog_node))
2815           {
2816             for (gnat_actual = First_Actual (gnat_node);
2817                  Present (gnat_actual);
2818                  gnat_actual = Next_Actual (gnat_actual))
2819               expand_expr_stmt (gnat_to_gnu (gnat_actual));
2820
2821             if (Nkind (gnat_node) == N_Function_Call)
2822               {
2823                 gnu_result_type = TREE_TYPE (gnu_subprog_type);
2824                 gnu_result
2825                   = build1 (NULL_EXPR, gnu_result_type,
2826                             build_call_raise (PE_Stubbed_Subprogram_Called));
2827               }
2828             else
2829               expand_expr_stmt
2830                 (build_call_raise (PE_Stubbed_Subprogram_Called));
2831             break;
2832           }
2833
2834         /* The only way we can be making a call via an access type is
2835            if Name is an explicit dereference.  In that case, get the
2836            list of formal args from the type the access type is pointing
2837            to.  Otherwise, get the formals from entity being called.  */
2838         if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2839           gnat_formal = First_Formal (Etype (Name (gnat_node)));
2840         else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2841           /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2842           gnat_formal = 0;
2843         else
2844           gnat_formal = First_Formal (Entity (Name (gnat_node)));
2845
2846         /* Create the list of the actual parameters as GCC expects it, namely
2847            a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2848            node is a parameter-expression and the TREE_PURPOSE field is
2849            null.  Skip OUT parameters that are not passed by reference and
2850            don't need to be copied in.  */
2851
2852         for (gnat_actual = First_Actual (gnat_node);
2853              Present (gnat_actual);
2854              gnat_formal = Next_Formal_With_Extras (gnat_formal),
2855              gnat_actual = Next_Actual (gnat_actual))
2856           {
2857             tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2858             /* We treat a conversion between aggregate types as if it
2859                is an unchecked conversion.  */
2860             int unchecked_convert_p
2861               = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2862                  || (Nkind (gnat_actual) == N_Type_Conversion
2863                      && Is_Composite_Type (Underlying_Type
2864                                            (Etype (gnat_formal)))));
2865             Node_Id gnat_name
2866               = unchecked_convert_p ? Expression (gnat_actual) : gnat_actual;
2867             tree gnu_name = gnat_to_gnu (gnat_name);
2868             tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
2869             tree gnu_actual;
2870
2871             /* If it's possible we may need to use this expression twice,
2872                make sure than any side-effects are handled via SAVE_EXPRs.
2873                Likewise if we need to force side-effects before the call.
2874                ??? This is more conservative than we need since we don't
2875                need to do this for pass-by-ref with no conversion.
2876                If we are passing a non-addressable Out or In Out parameter by
2877                reference, pass the address of a copy and set up to copy back
2878                out after the call.  */
2879
2880             if (Ekind (gnat_formal) != E_In_Parameter)
2881               {
2882                 gnu_name = gnat_stabilize_reference (gnu_name, 1);
2883                 if (! addressable_p (gnu_name)
2884                     && present_gnu_tree (gnat_formal)
2885                     && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2886                         || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2887                             && (DECL_BY_COMPONENT_PTR_P
2888                                 (get_gnu_tree (gnat_formal))
2889                                 || DECL_BY_DESCRIPTOR_P
2890                                 (get_gnu_tree (gnat_formal))))))
2891                   {
2892                     tree gnu_copy = gnu_name;
2893                     tree gnu_temp;
2894
2895                     /* Remove any unpadding on the actual and make a copy.
2896                        But if the actual is a left-justified modular type,
2897                        first convert to it.  */
2898                     if (TREE_CODE (gnu_name) == COMPONENT_REF
2899                         && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
2900                              == RECORD_TYPE)
2901                             && (TYPE_IS_PADDING_P
2902                                 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
2903                       gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
2904                     else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2905                              && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2906                                  (gnu_name_type)))
2907                       gnu_name = convert (gnu_name_type, gnu_name);
2908
2909                     gnu_actual = save_expr (gnu_name);
2910
2911                     /* Since we're going to take the address of the SAVE_EXPR,
2912                        we don't want it to be marked as unchanging.
2913                        So set TREE_ADDRESSABLE.  */
2914                     gnu_temp = skip_simple_arithmetic (gnu_actual);
2915                     if (TREE_CODE (gnu_temp) == SAVE_EXPR)
2916                       {
2917                         TREE_ADDRESSABLE (gnu_temp) = 1;
2918                         TREE_READONLY (gnu_temp) = 0;
2919                       }
2920
2921                     /* Set up to move the copy back to the original.  */
2922                     gnu_after_list = tree_cons (gnu_copy, gnu_actual,
2923                                                 gnu_after_list);
2924
2925                     gnu_name = gnu_actual;
2926                   }
2927               }
2928
2929             /* If this was a procedure call, we may not have removed any
2930                padding.  So do it here for the part we will use as an
2931                input, if any.  */
2932             gnu_actual = gnu_name;
2933             if (Ekind (gnat_formal) != E_Out_Parameter
2934                 && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2935                 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2936               gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2937                                     gnu_actual);
2938
2939             if (Ekind (gnat_formal) != E_Out_Parameter
2940                 && ! unchecked_convert_p
2941                 && Do_Range_Check (gnat_actual))
2942               gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
2943
2944             /* Do any needed conversions.  We need only check for
2945                unchecked conversion since normal conversions will be handled
2946                by just converting to the formal type.  */
2947             if (unchecked_convert_p)
2948               {
2949                 gnu_actual
2950                   = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2951                                        gnu_actual,
2952                                        (Nkind (gnat_actual)
2953                                         == N_Unchecked_Type_Conversion)
2954                                        && No_Truncation (gnat_actual));
2955
2956                 /* One we've done the unchecked conversion, we still
2957                    must ensure that the object is in range of the formal's
2958                    type.  */
2959                 if (Ekind (gnat_formal) != E_Out_Parameter
2960                     && Do_Range_Check (gnat_actual))
2961                   gnu_actual = emit_range_check (gnu_actual,
2962                                                  Etype (gnat_formal));
2963               }
2964             else if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2965               /* We may have suppressed a conversion to the Etype of the
2966                  actual since the parent is a procedure call.  So add the
2967                  conversion here.  */
2968               gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2969                                     gnu_actual);
2970
2971             if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2972               gnu_actual = convert (gnu_formal_type, gnu_actual);
2973
2974             /* If we have not saved a GCC object for the formal, it means it
2975                is an OUT parameter not passed by reference and that does not
2976                need to be copied in. Otherwise, look at the PARM_DECL to see
2977                if it is passed by reference. */
2978             if (present_gnu_tree (gnat_formal)
2979                 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2980                 && DECL_BY_REF_P (get_gnu_tree (gnat_formal)))
2981               {
2982                 if (Ekind (gnat_formal) != E_In_Parameter)
2983                   {
2984                     gnu_actual = gnu_name;
2985
2986                     /* If we have a padded type, be sure we've removed the
2987                        padding.  */
2988                     if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2989                         && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
2990                         && TREE_CODE (gnu_actual) != SAVE_EXPR)
2991                       gnu_actual
2992                         = convert (get_unpadded_type (Etype (gnat_actual)),
2993                                    gnu_actual);
2994                   }
2995
2996                 /* Otherwise, if we have a non-addressable COMPONENT_REF of a
2997                    variable-size type see if it's doing a unpadding operation.
2998                    If so, remove that operation since we have no way of
2999                    allocating the required temporary.  */
3000                 if (TREE_CODE (gnu_actual) == COMPONENT_REF
3001                     && ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
3002                     && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0)))
3003                         == RECORD_TYPE)
3004                     && TYPE_IS_PADDING_P (TREE_TYPE
3005                                           (TREE_OPERAND (gnu_actual, 0)))
3006                     && !addressable_p (gnu_actual))
3007                   gnu_actual = TREE_OPERAND (gnu_actual, 0);
3008
3009                 /* The symmetry of the paths to the type of an entity is
3010                    broken here since arguments don't know that they will
3011                    be passed by ref. */
3012                 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3013                 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type,
3014                                              gnu_actual);
3015               }
3016             else if (present_gnu_tree (gnat_formal)
3017                      && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3018                      && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)))
3019               {
3020                 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3021                 gnu_actual = maybe_implicit_deref (gnu_actual);
3022                 gnu_actual = maybe_unconstrained_array (gnu_actual);
3023
3024                 if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
3025                     && TYPE_IS_PADDING_P (gnu_formal_type))
3026                   {
3027                     gnu_formal_type
3028                       = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
3029                     gnu_actual = convert (gnu_formal_type, gnu_actual);
3030                   }
3031
3032                 /* Take the address of the object and convert to the
3033                    proper pointer type.  We'd like to actually compute
3034                    the address of the beginning of the array using
3035                    an ADDR_EXPR of an ARRAY_REF, but there's a possibility
3036                    that the ARRAY_REF might return a constant and we'd
3037                    be getting the wrong address.  Neither approach is
3038                    exactly correct, but this is the most likely to work
3039                    in all cases.  */
3040                 gnu_actual = convert (gnu_formal_type,
3041                                       build_unary_op (ADDR_EXPR, NULL_TREE,
3042                                                       gnu_actual));
3043               }
3044             else if (present_gnu_tree (gnat_formal)
3045                      && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3046                      && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal)))
3047               {
3048                 /* If arg is 'Null_Parameter, pass zero descriptor.  */
3049                 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
3050                      || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
3051                     && TREE_PRIVATE (gnu_actual))
3052                   gnu_actual
3053                     = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
3054                                integer_zero_node);
3055                 else
3056                   gnu_actual
3057                     = build_unary_op (ADDR_EXPR, NULL_TREE,
3058                                       fill_vms_descriptor (gnu_actual,
3059                                                            gnat_formal));
3060               }
3061             else
3062               {
3063                 tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
3064
3065                 if (Ekind (gnat_formal) != E_In_Parameter)
3066                   gnu_name_list
3067                     = chainon (gnu_name_list,
3068                                build_tree_list (NULL_TREE, gnu_name));
3069
3070                 if (! present_gnu_tree (gnat_formal)
3071                     || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL)
3072                   continue;
3073
3074                 /* If this is 'Null_Parameter, pass a zero even though we are
3075                    dereferencing it.  */
3076                 else if (TREE_CODE (gnu_actual) == INDIRECT_REF
3077                          && TREE_PRIVATE (gnu_actual)
3078                          && host_integerp (gnu_actual_size, 1)
3079                          && 0 >= compare_tree_int (gnu_actual_size,
3080                                                    BITS_PER_WORD))
3081                   gnu_actual
3082                     = unchecked_convert
3083                       (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
3084                        convert (gnat_type_for_size
3085                                 (tree_low_cst (gnu_actual_size, 1), 1),
3086                                 integer_zero_node), 0);
3087                 else
3088                   gnu_actual
3089                     = convert (TYPE_MAIN_VARIANT
3090                                (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))),
3091                                gnu_actual);
3092               }
3093
3094             gnu_actual_list
3095               = chainon (gnu_actual_list,
3096                          build_tree_list (NULL_TREE, gnu_actual));
3097           }
3098
3099         gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
3100                                   gnu_subprog_addr, gnu_actual_list,
3101                                   NULL_TREE);
3102         TREE_SIDE_EFFECTS (gnu_subprog_call) = 1;
3103
3104         /* If it is a function call, the result is the call expression.  */
3105         if (Nkind (gnat_node) == N_Function_Call)
3106           {
3107             gnu_result = gnu_subprog_call;
3108
3109             /* If the function returns an unconstrained array or by reference,
3110                we have to de-dereference the pointer.  */
3111             if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
3112                 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
3113               gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
3114                                            gnu_result);
3115
3116             gnu_result_type = get_unpadded_type (Etype (gnat_node));
3117           }
3118
3119         /* If this is the case where the GNAT tree contains a procedure call
3120            but the Ada procedure has copy in copy out parameters, the special
3121            parameter passing mechanism must be used.  */
3122         else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
3123           {
3124             /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3125                in copy out parameters.  */
3126             tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3127             int length = list_length (scalar_return_list);
3128
3129             if (length > 1)
3130               {
3131                 tree gnu_name;
3132
3133                 gnu_subprog_call = protect_multiple_eval (gnu_subprog_call);
3134
3135                 /* If any of the names had side-effects, ensure they are
3136                    all evaluated before the call.  */
3137                 for (gnu_name = gnu_name_list; gnu_name;
3138                      gnu_name = TREE_CHAIN (gnu_name))
3139                   if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
3140                     gnu_subprog_call
3141                       = build (COMPOUND_EXPR, TREE_TYPE (gnu_subprog_call),
3142                                TREE_VALUE (gnu_name), gnu_subprog_call);
3143               }
3144
3145             if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3146               gnat_formal = First_Formal (Etype (Name (gnat_node)));
3147             else
3148               gnat_formal = First_Formal (Entity (Name (gnat_node)));
3149
3150             for (gnat_actual = First_Actual (gnat_node);
3151                  Present (gnat_actual);
3152                  gnat_formal = Next_Formal_With_Extras (gnat_formal),
3153                  gnat_actual = Next_Actual (gnat_actual))
3154               /* If we are dealing with a copy in copy out parameter, we must
3155                  retrieve its value from the record returned in the function
3156                  call.  */
3157               if (! (present_gnu_tree (gnat_formal)
3158                      && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3159                      && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
3160                          || ((TREE_CODE (get_gnu_tree (gnat_formal))
3161                               == PARM_DECL)
3162                              && ((DECL_BY_COMPONENT_PTR_P
3163                                   (get_gnu_tree (gnat_formal))
3164                                   || (DECL_BY_DESCRIPTOR_P
3165                                       (get_gnu_tree (gnat_formal))))))))
3166                   && Ekind (gnat_formal) != E_In_Parameter)
3167                 {
3168                   /* Get the value to assign to this OUT or IN OUT
3169                      parameter.  It is either the result of the function if
3170                      there is only a single such parameter or the appropriate
3171                      field from the record returned.  */
3172                   tree gnu_result
3173                     = length == 1 ? gnu_subprog_call
3174                       : build_component_ref
3175                         (gnu_subprog_call, NULL_TREE,
3176                          TREE_PURPOSE (scalar_return_list), 0);
3177                   int unchecked_conversion
3178                     = Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
3179                   /* If the actual is a conversion, get the inner expression,
3180                      which will be the real destination, and convert the
3181                      result to the type of the actual parameter.  */
3182                   tree gnu_actual
3183                     = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3184
3185                   /* If the result is a padded type, remove the padding.  */
3186                   if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
3187                       && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3188                     gnu_result
3189                       = convert (TREE_TYPE (TYPE_FIELDS
3190                                             (TREE_TYPE (gnu_result))),
3191                                  gnu_result);
3192
3193                   /* If the result is a type conversion, do it.  */
3194                   if (Nkind (gnat_actual) == N_Type_Conversion)
3195                     gnu_result
3196                       = convert_with_check
3197                         (Etype (Expression (gnat_actual)), gnu_result,
3198                          Do_Overflow_Check (gnat_actual),
3199                          Do_Range_Check (Expression (gnat_actual)),
3200                          Float_Truncate (gnat_actual));
3201
3202                   else if (unchecked_conversion)
3203                     gnu_result
3204                       = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result,
3205                                            No_Truncation (gnat_actual));
3206                   else
3207                     {
3208                       if (Do_Range_Check (gnat_actual))
3209                         gnu_result = emit_range_check (gnu_result,
3210                                                        Etype (gnat_actual));
3211
3212                       if (! (! TREE_CONSTANT (TYPE_SIZE
3213                                               (TREE_TYPE (gnu_actual)))
3214                              && TREE_CONSTANT (TYPE_SIZE
3215                                                (TREE_TYPE (gnu_result)))))
3216                         gnu_result = convert (TREE_TYPE (gnu_actual),
3217                                               gnu_result);
3218                     }
3219
3220                   set_lineno (gnat_node, 1);
3221                   expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
3222                                                      gnu_actual, gnu_result));
3223                   scalar_return_list = TREE_CHAIN (scalar_return_list);
3224                   gnu_name_list = TREE_CHAIN (gnu_name_list);
3225                 }
3226           }
3227         else
3228           {
3229             set_lineno (gnat_node, 1);
3230             expand_expr_stmt (gnu_subprog_call);
3231           }
3232
3233         /* Handle anything we need to assign back.  */
3234         for (gnu_expr = gnu_after_list;
3235              gnu_expr;
3236              gnu_expr = TREE_CHAIN (gnu_expr))
3237           expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
3238                                              TREE_PURPOSE (gnu_expr),
3239                                              TREE_VALUE (gnu_expr)));
3240       }
3241       break;
3242
3243     /*************************/
3244     /* Chapter 7: Packages:  */
3245     /*************************/
3246
3247     case N_Package_Declaration:
3248       gnat_to_code (Specification (gnat_node));
3249       break;
3250
3251     case N_Package_Specification:
3252
3253       process_decls (Visible_Declarations (gnat_node),
3254                      Private_Declarations (gnat_node), Empty, 1, 1);
3255       break;
3256
3257     case N_Package_Body:
3258
3259       /* If this is the body of a generic package - do nothing */
3260       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
3261         break;
3262
3263       process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
3264
3265       if (Present (Handled_Statement_Sequence (gnat_node)))
3266         {
3267           gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
3268           gnat_to_code (Handled_Statement_Sequence (gnat_node));
3269           gnu_block_stack = TREE_CHAIN (gnu_block_stack);
3270         }
3271       break;
3272
3273     /*********************************/
3274     /* Chapter 8: Visibility Rules:  */
3275     /*********************************/
3276
3277     case N_Use_Package_Clause:
3278     case N_Use_Type_Clause:
3279       /* Nothing to do here - but these may appear in list of declarations */
3280       break;
3281
3282     /***********************/
3283     /* Chapter 9: Tasks:   */
3284     /***********************/
3285
3286     case N_Protected_Type_Declaration:
3287       break;
3288
3289     case N_Single_Task_Declaration:
3290       gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3291       break;
3292
3293     /***********************************************************/
3294     /* Chapter 10: Program Structure and Compilation Issues:   */
3295     /***********************************************************/
3296
3297     case N_Compilation_Unit:
3298
3299       /* For a body, first process the spec if there is one. */
3300       if (Nkind (Unit (gnat_node)) == N_Package_Body
3301           || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3302               && ! Acts_As_Spec (gnat_node)))
3303         gnat_to_code (Library_Unit (gnat_node));
3304
3305       process_inlined_subprograms (gnat_node);
3306
3307       if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3308         {
3309           elaborate_all_entities (gnat_node);
3310
3311           if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
3312               || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
3313               || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
3314             break;
3315         };
3316
3317       process_decls (Declarations (Aux_Decls_Node (gnat_node)),
3318                      Empty, Empty, 1, 1);
3319
3320       gnat_to_code (Unit (gnat_node));
3321
3322       /* Process any pragmas following the unit.  */
3323       if (Present (Pragmas_After (Aux_Decls_Node (gnat_node))))
3324         for (gnat_temp = First (Pragmas_After (Aux_Decls_Node (gnat_node)));
3325              gnat_temp; gnat_temp = Next (gnat_temp))
3326           gnat_to_code (gnat_temp);
3327
3328       /* Put all the Actions into the elaboration routine if we already had
3329          elaborations.  This will happen anyway if they are statements, but we
3330          want to force declarations there too due to order-of-elaboration
3331          issues.  Most should have Is_Statically_Allocated set.  If we
3332          have had no elaborations, we have no order-of-elaboration issue and
3333          don't want to create elaborations here.  */
3334       if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node))))
3335         for (gnat_temp = First (Actions (Aux_Decls_Node (gnat_node)));
3336              Present (gnat_temp); gnat_temp = Next (gnat_temp))
3337           {
3338             if (pending_elaborations_p ())
3339               add_pending_elaborations (NULL_TREE,
3340                                         make_transform_expr (gnat_temp));
3341             else
3342               gnat_to_code (gnat_temp);
3343           }
3344
3345       /* Generate elaboration code for this unit, if necessary, and
3346          say whether we did or not.  */
3347       Set_Has_No_Elaboration_Code
3348         (gnat_node,
3349          build_unit_elab
3350          (Defining_Entity (Unit (gnat_node)),
3351           Nkind (Unit (gnat_node)) == N_Package_Body
3352           || Nkind (Unit (gnat_node)) == N_Subprogram_Body,
3353           get_pending_elaborations ()));
3354
3355       break;
3356
3357     case N_Subprogram_Body_Stub:
3358     case N_Package_Body_Stub:
3359     case N_Protected_Body_Stub:
3360     case N_Task_Body_Stub:
3361       /* Simply process whatever unit is being inserted.  */
3362       gnat_to_code (Unit (Library_Unit (gnat_node)));
3363       break;
3364
3365     case N_Subunit:
3366       gnat_to_code (Proper_Body (gnat_node));
3367       break;
3368
3369     /***************************/
3370     /* Chapter 11: Exceptions: */
3371     /***************************/
3372
3373     case N_Handled_Sequence_Of_Statements:
3374
3375       /* The GCC exception handling mechanism can handle both ZCX and SJLJ
3376          schemes and we have our own SJLJ mechanism. To call the GCC
3377          mechanism, we first call expand_eh_region_start if there is at least
3378          one handler associated with the region.  We then generate code for
3379          the region and call expand_start_all_catch to announce that the
3380          associated handlers are going to be generated.
3381
3382          For each handler we call expand_start_catch, generate code for the
3383          handler, and then call expand_end_catch.
3384
3385          After all the handlers, we call expand_end_all_catch.
3386
3387          Here we deal with the region level calls and the
3388          N_Exception_Handler branch deals with the handler level calls
3389          (start_catch/end_catch).
3390
3391          ??? The region level calls down there have been specifically put in
3392          place for a ZCX context and currently the order in which things are
3393          emitted (region/handlers) is different from the SJLJ case. Instead of
3394          putting other calls with different conditions at other places for the
3395          SJLJ case, it seems cleaner to reorder things for the SJLJ case and
3396          generalize the condition to make it not ZCX specific. */
3397
3398       /* If there is an At_End procedure attached to this node, and the eh
3399          mechanism is GNAT oriented (SJLJ or ZCX with front end tables), we
3400          must have at least a corresponding At_End handler, unless the
3401          No_Exception_Handlers restriction is set.  */
3402       if (! type_annotate_only
3403           && Exception_Mechanism != GCC_ZCX
3404           && Present (At_End_Proc (gnat_node))
3405           && ! Present (Exception_Handlers (gnat_node))
3406           && ! No_Exception_Handlers_Set())
3407         gigi_abort (335);
3408
3409       {
3410         /* Need a binding level that we can exit for this sequence if there is
3411            at least one exception handler for this block (since each handler
3412            needs an identified exit point) or there is an At_End procedure
3413            attached to this node (in order to have an attachment point for a
3414            GCC cleanup).  */
3415         bool exitable_binding_for_block
3416           = (! type_annotate_only
3417              && (Present (Exception_Handlers (gnat_node))
3418                  || Present (At_End_Proc (gnat_node))));
3419
3420         /* Make a binding level that we can exit if we need one.  */
3421         if (exitable_binding_for_block)
3422           {
3423             pushlevel (0);
3424             expand_start_bindings (1);
3425           }
3426
3427         /* If we are to call a function when exiting this block, expand a GCC
3428            cleanup to take care. We have made a binding level for this cleanup
3429            above.  */
3430         if (Present (At_End_Proc (gnat_node)))
3431           {
3432             tree gnu_cleanup_call
3433               = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
3434
3435             tree gnu_cleanup_decl
3436               = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
3437                                  integer_type_node, NULL_TREE, 0, 0, 0, 0,
3438                                  0);
3439
3440             expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
3441           }
3442
3443         /* Now we generate the code for this block, with a different layout
3444            for GNAT SJLJ and for GCC or front end ZCX. The handlers come first
3445            in the GNAT SJLJ case, while they come after the handled sequence
3446            in the other cases.  */
3447
3448         /* First deal with possible handlers for the GNAT SJLJ scheme.  */
3449         if (! type_annotate_only
3450             && Exception_Mechanism == Setjmp_Longjmp
3451             && Present (Exception_Handlers (gnat_node)))
3452           {
3453             /* We already have a fresh binding level at hand. Declare a
3454                variable to save the old __gnat_jmpbuf value and a variable for
3455                our jmpbuf.  Call setjmp and handle each of the possible
3456                exceptions if it returns one. */
3457
3458             tree gnu_jmpsave_decl
3459               = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
3460                                  jmpbuf_ptr_type,
3461                                  build_call_0_expr (get_jmpbuf_decl),
3462                                  0, 0, 0, 0, 0);
3463
3464             tree gnu_jmpbuf_decl
3465               = create_var_decl (get_identifier ("JMP_BUF"),
3466                                  NULL_TREE, jmpbuf_type,
3467                                  NULL_TREE, 0, 0, 0, 0,
3468                                  0);
3469
3470             TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
3471
3472             /* When we exit this block, restore the saved value.  */
3473             expand_decl_cleanup (gnu_jmpsave_decl,
3474                                  build_call_1_expr (set_jmpbuf_decl,
3475                                                     gnu_jmpsave_decl));
3476
3477             /* Call setjmp and handle exceptions if it returns one.  */
3478             set_lineno (gnat_node, 1);
3479             expand_start_cond
3480               (build_call_1_expr (setjmp_decl,
3481                                   build_unary_op (ADDR_EXPR, NULL_TREE,
3482                                                   gnu_jmpbuf_decl)),
3483                0);
3484
3485             /* Restore our incoming longjmp value before we do anything.  */
3486             expand_expr_stmt
3487               (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
3488
3489             /* Make a binding level for the exception handling declarations
3490                and code. Don't assign it an exit label, since this is the
3491                outer block we want to exit at the end of each handler.  */
3492             pushlevel (0);
3493             expand_start_bindings (0);
3494
3495             gnu_except_ptr_stack
3496               = tree_cons (NULL_TREE,
3497                            create_var_decl
3498                            (get_identifier ("EXCEPT_PTR"), NULL_TREE,
3499                             build_pointer_type (except_type_node),
3500                             build_call_0_expr (get_excptr_decl),
3501                             0, 0, 0, 0, 0),
3502                            gnu_except_ptr_stack);
3503
3504             /* Generate code for each handler. The N_Exception_Handler case
3505                below does the real work. We ignore the dummy exception handler
3506                for the identifier case, as this is used only by the front
3507                end.  */
3508             for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3509                  Present (gnat_temp);
3510                  gnat_temp = Next_Non_Pragma (gnat_temp))
3511               gnat_to_code (gnat_temp);
3512
3513             /* If none of the exception handlers did anything, re-raise
3514                but do not defer abortion.  */
3515             set_lineno (gnat_node, 1);
3516             expand_expr_stmt
3517               (build_call_1_expr (raise_nodefer_decl,
3518                                   TREE_VALUE (gnu_except_ptr_stack)));
3519
3520             gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
3521
3522             /* End the binding level dedicated to the exception handlers.  */
3523             expand_end_bindings (getdecls (), kept_level_p (), -1);
3524             poplevel (kept_level_p (), 1, 0);
3525
3526             /* End the "if" on setjmp.  Note that we have arranged things so
3527                control never returns here.  */
3528             expand_end_cond ();
3529
3530             /* This is now immediately before the body proper. Set our jmp_buf
3531                as the current buffer.  */
3532             expand_expr_stmt
3533               (build_call_1_expr (set_jmpbuf_decl,
3534                                   build_unary_op (ADDR_EXPR, NULL_TREE,
3535                                                   gnu_jmpbuf_decl)));
3536           }
3537
3538         /* Now comes the processing for the sequence body.  */
3539
3540         /* If we use the back-end eh support, tell the back-end we are
3541            starting a new exception region.  */
3542         if (! type_annotate_only
3543             && Exception_Mechanism == GCC_ZCX
3544             && Present (Exception_Handlers (gnat_node)))
3545           expand_eh_region_start ();
3546
3547         /* Generate code and declarations for the prefix of this block,
3548            if any.  */
3549         if (Present (First_Real_Statement (gnat_node)))
3550           process_decls (Statements (gnat_node), Empty,
3551                          First_Real_Statement (gnat_node), 1, 1);
3552
3553         /* Generate code for each statement in the block.  */
3554         for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3555                           ? First_Real_Statement (gnat_node)
3556                           : First (Statements (gnat_node)));
3557              Present (gnat_temp);
3558              gnat_temp = Next (gnat_temp))
3559           gnat_to_code (gnat_temp);
3560
3561         /* Exit the binding level we made, if any.  */
3562         if (exitable_binding_for_block)
3563           expand_exit_something ();
3564
3565         /* Compile the handlers for front end ZCX or back-end supported
3566            exceptions.  */
3567         if (! type_annotate_only
3568             && Exception_Mechanism != Setjmp_Longjmp
3569             && Present (Exception_Handlers (gnat_node)))
3570           {
3571             if (Exception_Mechanism == GCC_ZCX)
3572               expand_start_all_catch ();
3573
3574             for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3575                  Present (gnat_temp);
3576                  gnat_temp = Next_Non_Pragma (gnat_temp))
3577               gnat_to_code (gnat_temp);
3578
3579             if (Exception_Mechanism == GCC_ZCX)
3580               expand_end_all_catch ();
3581           }
3582
3583         /* Close the binding level we made, if any.  */
3584         if (exitable_binding_for_block)
3585           {
3586             expand_end_bindings (getdecls (), kept_level_p (), -1);
3587             poplevel (kept_level_p (), 1, 0);
3588           }
3589       }
3590
3591       break;
3592
3593     case N_Exception_Handler:
3594       if (Exception_Mechanism == Setjmp_Longjmp)
3595         {
3596           /* Unless this is "Others" or the special "Non-Ada" exception
3597              for Ada, make an "if" statement to select the proper
3598              exceptions.  For "Others", exclude exceptions where
3599              Handled_By_Others is nonzero unless the All_Others flag is set.
3600              For "Non-ada", accept an exception if "Lang" is 'V'.  */
3601           tree gnu_choice = integer_zero_node;
3602
3603           for (gnat_temp = First (Exception_Choices (gnat_node));
3604                gnat_temp; gnat_temp = Next (gnat_temp))
3605             {
3606               tree this_choice;
3607
3608               if (Nkind (gnat_temp) == N_Others_Choice)
3609                 {
3610                   if (All_Others (gnat_temp))
3611                     this_choice = integer_one_node;
3612                   else
3613                     this_choice
3614                       = build_binary_op
3615                         (EQ_EXPR, integer_type_node,
3616                        convert
3617                        (integer_type_node,
3618                         build_component_ref
3619                         (build_unary_op
3620                          (INDIRECT_REF, NULL_TREE,
3621                           TREE_VALUE (gnu_except_ptr_stack)),
3622                          get_identifier ("not_handled_by_others"), NULL_TREE,
3623                          0)),
3624                          integer_zero_node);
3625                 }
3626
3627               else if (Nkind (gnat_temp) == N_Identifier
3628                        || Nkind (gnat_temp) == N_Expanded_Name)
3629                 {
3630                   Entity_Id gnat_ex_id = Entity (gnat_temp);
3631
3632                   /* Exception may be a renaming. Recover original exception
3633                      which is the one elaborated and registered.  */
3634                   if (Present (Renamed_Object (gnat_ex_id)))
3635                     gnat_ex_id = Renamed_Object (gnat_ex_id);
3636
3637                   gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3638
3639                   this_choice
3640                     = build_binary_op
3641                       (EQ_EXPR, integer_type_node,
3642                        TREE_VALUE (gnu_except_ptr_stack),
3643                        convert
3644                          (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
3645                           build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3646
3647                   /* If this is the distinguished exception "Non_Ada_Error"
3648                      (and we are in VMS mode), also allow a non-Ada
3649                      exception (a VMS condition) to match.  */
3650                   if (Is_Non_Ada_Error (Entity (gnat_temp)))
3651                     {
3652                       tree gnu_comp
3653                         = build_component_ref
3654                           (build_unary_op
3655                            (INDIRECT_REF, NULL_TREE,
3656                             TREE_VALUE (gnu_except_ptr_stack)),
3657                            get_identifier ("lang"), NULL_TREE, 0);
3658
3659                       this_choice
3660                         = build_binary_op
3661                         (TRUTH_ORIF_EXPR, integer_type_node,
3662                          build_binary_op
3663                          (EQ_EXPR, integer_type_node, gnu_comp,
3664                           convert (TREE_TYPE (gnu_comp),
3665                                    build_int_2 ('V', 0))),
3666                          this_choice);
3667                     }
3668                 }
3669               else
3670                 gigi_abort (318);
3671
3672               gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
3673                                             gnu_choice, this_choice);
3674             }
3675
3676           set_lineno (gnat_node, 1);
3677
3678           expand_start_cond (gnu_choice, 0);
3679         }
3680
3681       /* Tell the back end that we start an exception handler if necessary.  */
3682       if (Exception_Mechanism == GCC_ZCX)
3683         {
3684           /* We build a TREE_LIST of nodes representing what exception
3685              types this handler is able to catch, with special cases
3686              for others and all others cases.
3687
3688              Each exception type is actually identified by a pointer to the
3689              exception id, with special value zero for "others" and one for
3690              "all others". Beware that these special values are known and used
3691              by the personality routine to identify the corresponding specific
3692              kinds of handlers.
3693
3694              ??? For initial time frame reasons, the others and all_others
3695              cases have been handled using specific type trees, but this
3696              somehow hides information to the back-end, which expects NULL to
3697              be passed for catch all and end_cleanup to be used for cleanups.
3698
3699              Care should be taken to ensure that the control flow impact of
3700              such clauses is rendered in some way. lang_eh_type_covers is
3701              doing the trick currently.  */
3702
3703           tree gnu_expr, gnu_etype;
3704           tree gnu_etypes_list = NULL_TREE;
3705
3706           for (gnat_temp = First (Exception_Choices (gnat_node));
3707                gnat_temp; gnat_temp = Next (gnat_temp))
3708             {
3709               if (Nkind (gnat_temp) == N_Others_Choice)
3710                 gnu_etype
3711                   = All_Others (gnat_temp) ? integer_one_node
3712                     : integer_zero_node;
3713               else if (Nkind (gnat_temp) == N_Identifier
3714                        || Nkind (gnat_temp) == N_Expanded_Name)
3715                 {
3716                   Entity_Id gnat_ex_id = Entity (gnat_temp);
3717
3718                   /* Exception may be a renaming. Recover original exception
3719                      which is the one elaborated and registered.  */
3720                   if (Present (Renamed_Object (gnat_ex_id)))
3721                     gnat_ex_id = Renamed_Object (gnat_ex_id);
3722
3723                   gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3724
3725                   gnu_etype
3726                     = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3727
3728                   /* The Non_Ada_Error case for VMS exceptions is handled
3729                      by the personality routine.  */
3730                 }
3731               else
3732                 gigi_abort (337);
3733
3734               /* The GCC interface expects NULL to be passed for catch all
3735                  handlers, so it would be quite tempting to set gnu_etypes_list
3736                  to NULL if gnu_etype is integer_zero_node.  It would not work,
3737                  however, because GCC's notion of "catch all" is stronger than
3738                  our notion of "others".  Until we correctly use the cleanup
3739                  interface as well, the doing tht would prevent the "all
3740                  others" handlers from beeing seen, because nothing can be
3741                  caught beyond a catch all from GCC's point of view.  */
3742               gnu_etypes_list
3743                 = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3744
3745             }
3746
3747           expand_start_catch (gnu_etypes_list);
3748
3749           pushlevel (0);
3750           expand_start_bindings (0);
3751
3752           {
3753             /* Expand a call to the begin_handler hook at the beginning of the
3754                handler, and arrange for a call to the end_handler hook to
3755                occur on every possible exit path.
3756
3757                The hooks expect a pointer to the low level occurrence. This
3758                is required for our stack management scheme because a raise
3759                inside the handler pushes a new occurrence on top of the
3760                stack, which means that this top does not necessarily match
3761                the occurrence this handler was dealing with.
3762
3763                The EXC_PTR_EXPR object references the exception occurrence
3764                beeing propagated. Upon handler entry, this is the exception
3765                for which the handler is triggered. This might not be the case
3766                upon handler exit, however, as we might have a new occurrence
3767                propagated by the handler's body, and the end_handler hook
3768                called as a cleanup in this context.
3769
3770                We use a local variable to retrieve the incoming value at
3771                handler entry time, and reuse it to feed the end_handler
3772                hook's argument at exit time.  */
3773             tree gnu_current_exc_ptr
3774               = build (EXC_PTR_EXPR, ptr_type_node);
3775             tree gnu_incoming_exc_ptr
3776               = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3777                                  ptr_type_node, gnu_current_exc_ptr,
3778                                  0, 0, 0, 0, 0);
3779
3780             expand_expr_stmt
3781               (build_call_1_expr (begin_handler_decl, gnu_incoming_exc_ptr));
3782             expand_decl_cleanup
3783               (0, build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr));
3784           }
3785         }
3786
3787       for (gnat_temp = First (Statements (gnat_node));
3788            gnat_temp; gnat_temp = Next (gnat_temp))
3789         gnat_to_code (gnat_temp);
3790
3791       if (Exception_Mechanism == GCC_ZCX)
3792         {
3793           /* Tell the back end that we're done with the current handler.  */
3794           expand_end_bindings (getdecls (), kept_level_p (), -1);
3795           poplevel (kept_level_p (), 1, 0);
3796
3797           expand_end_catch ();
3798         }
3799       else
3800         /* At the end of the handler, exit the block. We made this block in
3801            N_Handled_Sequence_Of_Statements.  */
3802         expand_exit_something ();
3803
3804       if (Exception_Mechanism == Setjmp_Longjmp)
3805         expand_end_cond ();
3806
3807       break;
3808
3809     /*******************************/
3810     /* Chapter 12: Generic Units:  */
3811     /*******************************/
3812
3813     case N_Generic_Function_Renaming_Declaration:
3814     case N_Generic_Package_Renaming_Declaration:
3815     case N_Generic_Procedure_Renaming_Declaration:
3816     case N_Generic_Package_Declaration:
3817     case N_Generic_Subprogram_Declaration:
3818     case N_Package_Instantiation:
3819     case N_Procedure_Instantiation:
3820     case N_Function_Instantiation:
3821       /* These nodes can appear on a declaration list but there is nothing to
3822          to be done with them.  */
3823       break;
3824
3825     /***************************************************/
3826     /* Chapter 13: Representation Clauses and          */
3827     /*             Implementation-Dependent Features:  */
3828     /***************************************************/
3829
3830     case N_Attribute_Definition_Clause:
3831
3832       /* The only one we need deal with is for 'Address.  For the others, SEM
3833          puts the information elsewhere.  We need only deal with 'Address
3834          if the object has a Freeze_Node (which it never will currently).  */
3835       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
3836           || No (Freeze_Node (Entity (Name (gnat_node)))))
3837         break;
3838
3839       /* Get the value to use as the address and save it as the
3840          equivalent for GNAT_TEMP.  When the object is frozen,
3841          gnat_to_gnu_entity will do the right thing. */
3842       gnu_expr = gnat_to_gnu (Expression (gnat_node));
3843       save_gnu_tree (Entity (Name (gnat_node)), gnu_expr, 1);
3844       break;
3845
3846     case N_Enumeration_Representation_Clause:
3847     case N_Record_Representation_Clause:
3848     case N_At_Clause:
3849       /* We do nothing with these.  SEM puts the information elsewhere.  */
3850       break;
3851
3852     case N_Code_Statement:
3853       if (! type_annotate_only)
3854         {
3855           tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
3856           tree gnu_input_list = 0, gnu_output_list = 0, gnu_orig_out_list = 0;
3857           tree gnu_clobber_list = 0;
3858           char *clobber;
3859
3860           /* First process inputs, then outputs, then clobbers.  */
3861           Setup_Asm_Inputs (gnat_node);
3862           while (Present (gnat_temp = Asm_Input_Value ()))
3863             {
3864               tree gnu_value = gnat_to_gnu (gnat_temp);
3865               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3866                                                  (Asm_Input_Constraint ()));
3867
3868               gnu_input_list
3869                 = tree_cons (gnu_constr, gnu_value, gnu_input_list);
3870               Next_Asm_Input ();
3871             }
3872
3873           Setup_Asm_Outputs (gnat_node);
3874           while (Present (gnat_temp = Asm_Output_Variable ()))
3875             {
3876               tree gnu_value = gnat_to_gnu (gnat_temp);
3877               tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3878                                                  (Asm_Output_Constraint ()));
3879
3880               gnu_orig_out_list
3881                 = tree_cons (gnu_constr, gnu_value, gnu_orig_out_list);
3882               gnu_output_list
3883                 = tree_cons (gnu_constr, gnu_value, gnu_output_list);
3884               Next_Asm_Output ();
3885             }
3886
3887           Clobber_Setup (gnat_node);
3888           while ((clobber = Clobber_Get_Next ()) != 0)
3889             gnu_clobber_list
3890               = tree_cons (NULL_TREE,
3891                            build_string (strlen (clobber) + 1, clobber),
3892                            gnu_clobber_list);
3893
3894           gnu_input_list = nreverse (gnu_input_list);
3895           gnu_output_list = nreverse (gnu_output_list);
3896           gnu_orig_out_list = nreverse (gnu_orig_out_list);
3897           expand_asm_operands (gnu_template, gnu_output_list, gnu_input_list,
3898                                gnu_clobber_list, Is_Asm_Volatile (gnat_node),
3899                                input_location);
3900
3901           /* Copy all the intermediate outputs into the specified outputs.  */
3902           for (; gnu_output_list;
3903                (gnu_output_list = TREE_CHAIN (gnu_output_list),
3904                 gnu_orig_out_list = TREE_CHAIN (gnu_orig_out_list)))
3905             if (TREE_VALUE (gnu_orig_out_list) != TREE_VALUE (gnu_output_list))
3906               {
3907                 expand_expr_stmt
3908                   (build_binary_op (MODIFY_EXPR, NULL_TREE,
3909                                     TREE_VALUE (gnu_orig_out_list),
3910                                     TREE_VALUE (gnu_output_list)));
3911                 free_temp_slots ();
3912               }
3913         }
3914       break;
3915
3916     /***************************************************/
3917     /* Added Nodes                                     */
3918     /***************************************************/
3919
3920     case N_Freeze_Entity:
3921       process_freeze_entity (gnat_node);
3922       process_decls (Actions (gnat_node), Empty, Empty, 1, 1);
3923       break;
3924
3925     case N_Itype_Reference:
3926       if (! present_gnu_tree (Itype (gnat_node)))
3927         process_type (Itype (gnat_node));
3928       break;
3929
3930     case N_Free_Statement:
3931       if (! type_annotate_only)
3932         {
3933           tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
3934           tree gnu_obj_type;
3935           tree gnu_obj_size;
3936           int align;
3937
3938           /* If this is a thin pointer, we must dereference it to create
3939              a fat pointer, then go back below to a thin pointer.  The
3940              reason for this is that we need a fat pointer someplace in
3941              order to properly compute the size.  */
3942           if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
3943             gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
3944                                       build_unary_op (INDIRECT_REF, NULL_TREE,
3945                                                       gnu_ptr));
3946
3947           /* If this is an unconstrained array, we know the object must
3948              have been allocated with the template in front of the object.
3949              So pass the template address, but get the total size.  Do this
3950              by converting to a thin pointer.  */
3951           if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
3952             gnu_ptr
3953               = convert (build_pointer_type
3954                          (TYPE_OBJECT_RECORD_TYPE
3955                           (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
3956                          gnu_ptr);
3957
3958           gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
3959           gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
3960           align = TYPE_ALIGN (gnu_obj_type);
3961
3962           if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
3963               && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
3964             {
3965               tree gnu_char_ptr_type = build_pointer_type (char_type_node);
3966               tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
3967               tree gnu_byte_offset
3968                 = convert (gnu_char_ptr_type,
3969                            size_diffop (size_zero_node, gnu_pos));
3970
3971               gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
3972               gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
3973                                          gnu_ptr, gnu_byte_offset);
3974             }
3975
3976           set_lineno (gnat_node, 1);
3977           expand_expr_stmt
3978             (build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
3979                                        Procedure_To_Call (gnat_node),
3980                                        Storage_Pool (gnat_node), gnat_node));
3981         }
3982       break;
3983
3984     case N_Raise_Constraint_Error:
3985     case N_Raise_Program_Error:
3986     case N_Raise_Storage_Error:
3987
3988       if (type_annotate_only)
3989         break;
3990
3991       gnu_result_type = get_unpadded_type (Etype (gnat_node));
3992       gnu_result = build_call_raise (UI_To_Int (Reason (gnat_node)));
3993
3994       /* If the type is VOID, this is a statement, so we need to
3995          generate the code for the call.  Handle a Condition, if there
3996          is one.  */
3997       if (TREE_CODE (gnu_result_type) == VOID_TYPE)
3998         {
3999           set_lineno (gnat_node, 1);
4000
4001           if (Present (Condition (gnat_node)))
4002             expand_start_cond (gnat_to_gnu (Condition (gnat_node)), 0);
4003
4004           expand_expr_stmt (gnu_result);
4005           if (Present (Condition (gnat_node)))
4006             expand_end_cond ();
4007           gnu_result = error_mark_node;
4008         }
4009       else
4010         gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
4011       break;
4012
4013     case N_Validate_Unchecked_Conversion:
4014       /* If the result is a pointer type, see if we are either converting
4015          from a non-pointer or from a pointer to a type with a different
4016          alias set and warn if so.  If the result defined in the same unit as
4017          this unchecked convertion, we can allow this because we can know to
4018          make that type have alias set 0.  */
4019       {
4020         tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
4021         tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
4022
4023         if (POINTER_TYPE_P (gnu_target_type)
4024             && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node)
4025             && get_alias_set (TREE_TYPE (gnu_target_type)) != 0
4026             && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node)))
4027             && (!POINTER_TYPE_P (gnu_source_type)
4028                 || (get_alias_set (TREE_TYPE (gnu_source_type))
4029                     != get_alias_set (TREE_TYPE (gnu_target_type)))))
4030           {
4031             post_error_ne
4032               ("?possible aliasing problem for type&",
4033                gnat_node, Target_Type (gnat_node));
4034             post_error
4035               ("\\?use -fno-strict-aliasing switch for references",
4036                gnat_node);
4037             post_error_ne
4038               ("\\?or use `pragma No_Strict_Aliasing (&);`",
4039                gnat_node, Target_Type (gnat_node));
4040           }
4041       }
4042       break;
4043
4044     case N_Raise_Statement:
4045     case N_Function_Specification:
4046     case N_Procedure_Specification:
4047     case N_Op_Concat:
4048     case N_Component_Association:
4049     case N_Task_Body:
4050     default:
4051       if (! type_annotate_only)
4052         gigi_abort (321);
4053     }
4054
4055   /* If the result is a statement, set needed flags and return it.  */
4056   if (IS_STMT (gnu_result))
4057     {
4058       TREE_TYPE (gnu_result) = void_type_node;
4059       TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
4060       TREE_SLOC (gnu_result) = Sloc (gnat_node);
4061       return gnu_result;
4062     }
4063
4064   /* If the result is a constant that overflows, raise constraint error.  */
4065   else if (TREE_CODE (gnu_result) == INTEGER_CST
4066       && TREE_CONSTANT_OVERFLOW (gnu_result))
4067     {
4068       post_error ("Constraint_Error will be raised at run-time?", gnat_node);
4069
4070       gnu_result
4071         = build1 (NULL_EXPR, gnu_result_type,
4072                   build_call_raise (CE_Overflow_Check_Failed));
4073     }
4074
4075   /* If our result has side-effects and is of an unconstrained type,
4076      make a SAVE_EXPR so that we can be sure it will only be referenced
4077      once.  Note we must do this before any conversions.  */
4078   if (TREE_SIDE_EFFECTS (gnu_result)
4079       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
4080           || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
4081     gnu_result = gnat_stabilize_reference (gnu_result, 0);
4082
4083   /* Now convert the result to the proper type.  If the type is void or if
4084      we have no result, return error_mark_node to show we have no result.
4085      If the type of the result is correct or if we have a label (which doesn't
4086      have any well-defined type), return our result.  Also don't do the
4087      conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4088      since those are the cases where the front end may have the type wrong due
4089      to "instantiating" the unconstrained record with discriminant values
4090      or if this is a FIELD_DECL.  If this is the Name of an assignment
4091      statement or a parameter of a procedure call, return what we have since
4092      the RHS has to be converted to our type there in that case, unless
4093      GNU_RESULT_TYPE has a simpler size.  Similarly, if the two types are
4094      record types with the same name, the expression type has integral mode,
4095      and GNU_RESULT_TYPE BLKmode, don't convert.  This will be the case when
4096      we are converting from a packable type to its actual type and we need
4097      those conversions to be NOPs in order for assignments into these types to
4098      work properly if the inner object is a bitfield and hence can't have
4099      its address taken.  Finally, don't convert integral types that are the
4100      operand of an unchecked conversion since we need to ignore those
4101      conversions (for 'Valid).  Otherwise, convert the result to the proper
4102      type.  */
4103
4104   if (Present (Parent (gnat_node))
4105       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
4106            && Name (Parent (gnat_node)) == gnat_node)
4107           || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
4108               && Name (Parent (gnat_node)) != gnat_node)
4109           || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
4110               && ! AGGREGATE_TYPE_P (gnu_result_type)
4111               && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4112           || Nkind (Parent (gnat_node)) == N_Parameter_Association)
4113       && ! (TYPE_SIZE (gnu_result_type) != 0
4114             && TYPE_SIZE (TREE_TYPE (gnu_result)) != 0
4115             && (AGGREGATE_TYPE_P (gnu_result_type)
4116                 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4117             && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
4118                  && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
4119                      != INTEGER_CST))
4120                 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4121                     && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
4122                     && (CONTAINS_PLACEHOLDER_P
4123                         (TYPE_SIZE (TREE_TYPE (gnu_result))))))
4124             && ! (TREE_CODE (gnu_result_type) == RECORD_TYPE
4125                   && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type))))
4126     {
4127       /* In this case remove padding only if the inner object is of
4128          self-referential size: in that case it must be an object of
4129          unconstrained type with a default discriminant.  In other cases,
4130          we want to avoid copying too much data.  */
4131       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4132           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
4133           && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4134                                      (TREE_TYPE (TYPE_FIELDS
4135                                                  (TREE_TYPE (gnu_result))))))
4136         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4137                               gnu_result);
4138     }
4139
4140   else if (TREE_CODE (gnu_result) == LABEL_DECL
4141            || TREE_CODE (gnu_result) == FIELD_DECL
4142            || TREE_CODE (gnu_result) == ERROR_MARK
4143            || (TYPE_SIZE (gnu_result_type) != 0
4144                && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4145                && TREE_CODE (gnu_result) != INDIRECT_REF
4146                && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
4147            || ((TYPE_NAME (gnu_result_type)
4148                 == TYPE_NAME (TREE_TYPE (gnu_result)))
4149                && TREE_CODE (gnu_result_type) == RECORD_TYPE
4150                && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4151                && TYPE_MODE (gnu_result_type) == BLKmode
4152                && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
4153                    == MODE_INT)))
4154     {
4155       /* Remove any padding record, but do nothing more in this case.  */
4156       if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4157           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4158         gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4159                               gnu_result);
4160     }
4161
4162   else if (gnu_result == error_mark_node
4163            || gnu_result_type == void_type_node)
4164     gnu_result =  error_mark_node;
4165   else if (gnu_result_type != TREE_TYPE (gnu_result))
4166     gnu_result = convert (gnu_result_type, gnu_result);
4167
4168   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT.  */
4169   while ((TREE_CODE (gnu_result) == NOP_EXPR
4170           || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
4171          && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
4172     gnu_result = TREE_OPERAND (gnu_result, 0);
4173
4174   return gnu_result;
4175 }
4176 \f
4177 /* GNU_STMT is a statement.  We generate code for that statement.  */
4178
4179 void
4180 gnat_expand_stmt (tree gnu_stmt)
4181 {
4182   set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
4183
4184   switch (TREE_CODE (gnu_stmt))
4185     {
4186     case EXPR_STMT:
4187       expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
4188       break;
4189
4190     default:
4191       abort ();
4192     }
4193 }
4194 \f
4195 /* Force references to each of the entities in packages GNAT_NODE with's
4196    so that the debugging information for all of them are identical
4197    in all clients.  Operate recursively on anything it with's, but check
4198    that we aren't elaborating something more than once.  */
4199
4200 /* The reason for this routine's existence is two-fold.
4201    First, with some debugging formats, notably MDEBUG on SGI
4202    IRIX, the linker will remove duplicate debugging information if two
4203    clients have identical debugguing information.  With the normal scheme
4204    of elaboration, this does not usually occur, since entities in with'ed
4205    packages are elaborated on demand, and if clients have different usage
4206    patterns, the normal case, then the order and selection of entities
4207    will differ.  In most cases however, it seems that linkers do not know
4208    how to eliminate duplicate debugging information, even if it is
4209    identical, so the use of this routine would increase the total amount
4210    of debugging information in the final executable.
4211
4212    Second, this routine is called in type_annotate mode, to compute DDA
4213    information for types in withed units, for ASIS use  */
4214
4215 static void
4216 elaborate_all_entities (Node_Id gnat_node)
4217 {
4218   Entity_Id gnat_with_clause, gnat_entity;
4219
4220   /* Process each unit only once. As we trace the context of all relevant
4221      units transitively, including generic bodies, we may encounter the
4222      same generic unit repeatedly */
4223
4224   if (!present_gnu_tree (gnat_node))
4225      save_gnu_tree (gnat_node, integer_zero_node, 1);
4226
4227   /* Save entities in all context units. A body may have an implicit_with
4228      on its own spec, if the context includes a child unit, so don't save
4229      the spec twice.  */
4230
4231   for (gnat_with_clause = First (Context_Items (gnat_node));
4232        Present (gnat_with_clause);
4233        gnat_with_clause = Next (gnat_with_clause))
4234     if (Nkind (gnat_with_clause) == N_With_Clause
4235         && ! present_gnu_tree (Library_Unit (gnat_with_clause))
4236         && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
4237       {
4238         elaborate_all_entities (Library_Unit (gnat_with_clause));
4239
4240         if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
4241           {
4242             for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
4243                  Present (gnat_entity);
4244                  gnat_entity = Next_Entity (gnat_entity))
4245               if (Is_Public (gnat_entity)
4246                   && Convention (gnat_entity) != Convention_Intrinsic
4247                   && Ekind (gnat_entity) != E_Package
4248                   && Ekind (gnat_entity) != E_Package_Body
4249                   && Ekind (gnat_entity) != E_Operator
4250                   && ! (IN (Ekind (gnat_entity), Type_Kind)
4251                         && ! Is_Frozen (gnat_entity))
4252                   && ! ((Ekind (gnat_entity) == E_Procedure
4253                          || Ekind (gnat_entity) == E_Function)
4254                         && Is_Intrinsic_Subprogram (gnat_entity))
4255                   && ! IN (Ekind (gnat_entity), Named_Kind)
4256                   && ! IN (Ekind (gnat_entity), Generic_Unit_Kind))
4257                 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4258           }
4259         else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
4260            {
4261             Node_Id gnat_body
4262               = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
4263
4264             /* Retrieve compilation unit node of generic body.  */
4265             while (Present (gnat_body)
4266                    && Nkind (gnat_body) != N_Compilation_Unit)
4267               gnat_body = Parent (gnat_body);
4268
4269             /* If body is available, elaborate its context.  */
4270             if (Present (gnat_body))
4271                 elaborate_all_entities (gnat_body);
4272            }
4273       }
4274
4275   if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
4276     elaborate_all_entities (Library_Unit (gnat_node));
4277 }
4278 \f
4279 /* Do the processing of N_Freeze_Entity, GNAT_NODE.  */
4280
4281 static void
4282 process_freeze_entity (Node_Id gnat_node)
4283 {
4284   Entity_Id gnat_entity = Entity (gnat_node);
4285   tree gnu_old;
4286   tree gnu_new;
4287   tree gnu_init
4288     = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
4289        && present_gnu_tree (Declaration_Node (gnat_entity)))
4290       ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
4291
4292   /* If this is a package, need to generate code for the package.  */
4293   if (Ekind (gnat_entity) == E_Package)
4294     {
4295       insert_code_for
4296         (Parent (Corresponding_Body
4297                  (Parent (Declaration_Node (gnat_entity)))));
4298       return;
4299     }
4300
4301   /* Check for old definition after the above call.  This Freeze_Node
4302      might be for one its Itypes.  */
4303   gnu_old
4304     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4305
4306   /* If this entity has an Address representation clause, GNU_OLD is the
4307      address, so discard it here.  */
4308   if (Present (Address_Clause (gnat_entity)))
4309     gnu_old = 0;
4310
4311   /* Don't do anything for class-wide types they are always
4312      transformed into their root type.  */
4313   if (Ekind (gnat_entity) == E_Class_Wide_Type
4314       || (Ekind (gnat_entity) == E_Class_Wide_Subtype
4315           && Present (Equivalent_Type (gnat_entity))))
4316     return;
4317
4318   /* Don't do anything for subprograms that may have been elaborated before
4319      their freeze nodes.  This can happen, for example because of an inner call
4320      in an instance body.  */
4321   if (gnu_old != 0
4322        && TREE_CODE (gnu_old) == FUNCTION_DECL
4323        && (Ekind (gnat_entity) == E_Function
4324           || Ekind (gnat_entity) == E_Procedure))
4325     return;
4326
4327   /* If we have a non-dummy type old tree, we have nothing to do.   Unless
4328      this is the public view of a private type whose full view was not
4329      delayed, this node was never delayed as it should have been.
4330      Also allow this to happen for concurrent types since we may have
4331      frozen both the Corresponding_Record_Type and this type.  */
4332   if (gnu_old != 0
4333       && ! (TREE_CODE (gnu_old) == TYPE_DECL
4334             && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
4335     {
4336       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4337           && Present (Full_View (gnat_entity))
4338           && No (Freeze_Node (Full_View (gnat_entity))))
4339         return;
4340       else if (Is_Concurrent_Type (gnat_entity))
4341         return;
4342       else
4343         gigi_abort (320);
4344     }
4345
4346   /* Reset the saved tree, if any, and elaborate the object or type for real.
4347      If there is a full declaration, elaborate it and copy the type to
4348      GNAT_ENTITY.  Likewise if this is the record subtype corresponding to
4349      a class wide type or subtype.  */
4350   if (gnu_old != 0)
4351     {
4352       save_gnu_tree (gnat_entity, NULL_TREE, 0);
4353       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4354           && Present (Full_View (gnat_entity))
4355           && present_gnu_tree (Full_View (gnat_entity)))
4356         save_gnu_tree (Full_View (gnat_entity), NULL_TREE, 0);
4357       if (Present (Class_Wide_Type (gnat_entity))
4358           && Class_Wide_Type (gnat_entity) != gnat_entity)
4359         save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, 0);
4360     }
4361
4362   if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4363       && Present (Full_View (gnat_entity)))
4364     {
4365       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
4366
4367       /* The above call may have defined this entity (the simplest example
4368          of this is when we have a private enumeral type since the bounds
4369          will have the public view.  */
4370       if (! present_gnu_tree (gnat_entity))
4371         save_gnu_tree (gnat_entity, gnu_new, 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), gnu_new, 0);
4375     }
4376   else
4377     gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
4378
4379   /* If we've made any pointers to the old version of this type, we
4380      have to update them.  */
4381   if (gnu_old != 0)
4382     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4383                        TREE_TYPE (gnu_new));
4384 }
4385 \f
4386 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4387    N_Compilation_Unit.  */
4388
4389 static void
4390 process_inlined_subprograms (Node_Id gnat_node)
4391 {
4392   Entity_Id gnat_entity;
4393   Node_Id gnat_body;
4394
4395   /* If we can inline, generate RTL for all the inlined subprograms.
4396      Define the entity first so we set DECL_EXTERNAL.  */
4397   if (optimize > 0 && ! flag_no_inline)
4398     for (gnat_entity = First_Inlined_Subprogram (gnat_node);
4399          Present (gnat_entity);
4400          gnat_entity = Next_Inlined_Subprogram (gnat_entity))
4401       {
4402         gnat_body = Parent (Declaration_Node (gnat_entity));
4403
4404         if (Nkind (gnat_body) != N_Subprogram_Body)
4405           {
4406             /* ??? This really should always be Present.  */
4407             if (No (Corresponding_Body (gnat_body)))
4408               continue;
4409
4410             gnat_body
4411               = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
4412           }
4413
4414         if (Present (gnat_body))
4415           {
4416             gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4417             gnat_to_code (gnat_body);
4418           }
4419       }
4420 }
4421 \f
4422 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4423    We make two passes, one to elaborate anything other than bodies (but
4424    we declare a function if there was no spec).  The second pass
4425    elaborates the bodies.
4426
4427    GNAT_END_LIST gives the element in the list past the end.  Normally,
4428    this is Empty, but can be First_Real_Statement for a
4429    Handled_Sequence_Of_Statements.
4430
4431    We make a complete pass through both lists if PASS1P is true, then make
4432    the second pass over both lists if PASS2P is true.  The lists usually
4433    correspond to the public and private parts of a package.  */
4434
4435 static void
4436 process_decls (List_Id gnat_decls,
4437                List_Id gnat_decls2,
4438                Node_Id gnat_end_list,
4439                int pass1p,
4440                int pass2p)
4441 {
4442   List_Id gnat_decl_array[2];
4443   Node_Id gnat_decl;
4444   int i;
4445
4446   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
4447
4448   if (pass1p)
4449     for (i = 0; i <= 1; i++)
4450       if (Present (gnat_decl_array[i]))
4451         for (gnat_decl = First (gnat_decl_array[i]);
4452              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4453           {
4454             set_lineno (gnat_decl, 0);
4455
4456             /* For package specs, we recurse inside the declarations,
4457                thus taking the two pass approach inside the boundary.  */
4458             if (Nkind (gnat_decl) == N_Package_Declaration
4459                 && (Nkind (Specification (gnat_decl)
4460                            == N_Package_Specification)))
4461               process_decls (Visible_Declarations (Specification (gnat_decl)),
4462                              Private_Declarations (Specification (gnat_decl)),
4463                              Empty, 1, 0);
4464
4465             /* Similarly for any declarations in the actions of a
4466                freeze node.  */
4467             else if (Nkind (gnat_decl) == N_Freeze_Entity)
4468               {
4469                 process_freeze_entity (gnat_decl);
4470                 process_decls (Actions (gnat_decl), Empty, Empty, 1, 0);
4471               }
4472
4473             /* Package bodies with freeze nodes get their elaboration deferred
4474                until the freeze node, but the code must be placed in the right
4475                place, so record the code position now.  */
4476             else if (Nkind (gnat_decl) == N_Package_Body
4477                      && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
4478               record_code_position (gnat_decl);
4479
4480             else if (Nkind (gnat_decl) == N_Package_Body_Stub
4481                      && Present (Library_Unit (gnat_decl))
4482                      && Present (Freeze_Node
4483                                  (Corresponding_Spec
4484                                   (Proper_Body (Unit
4485                                                 (Library_Unit (gnat_decl)))))))
4486               record_code_position
4487                 (Proper_Body (Unit (Library_Unit (gnat_decl))));
4488
4489             /* We defer most subprogram bodies to the second pass.  */
4490             else if (Nkind (gnat_decl) == N_Subprogram_Body)
4491               {
4492                 if (Acts_As_Spec (gnat_decl))
4493                   {
4494                     Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
4495
4496                     if (Ekind (gnat_subprog_id) != E_Generic_Procedure
4497                         && Ekind (gnat_subprog_id) != E_Generic_Function)
4498                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4499                   }
4500               }
4501             /* For bodies and stubs that act as their own specs, the entity
4502                itself must be elaborated in the first pass, because it may
4503                be used in other declarations. */
4504             else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
4505               {
4506                   Node_Id gnat_subprog_id =
4507                      Defining_Entity (Specification (gnat_decl));
4508
4509                     if    (Ekind (gnat_subprog_id) != E_Subprogram_Body
4510                         && Ekind (gnat_subprog_id) != E_Generic_Procedure
4511                         && Ekind (gnat_subprog_id) != E_Generic_Function)
4512                       gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4513                }
4514
4515             /* Concurrent stubs stand for the corresponding subprogram bodies,
4516                which are deferred like other bodies.  */
4517               else if (Nkind (gnat_decl) == N_Task_Body_Stub
4518                        || Nkind (gnat_decl) == N_Protected_Body_Stub)
4519                 ;
4520
4521             else
4522               gnat_to_code (gnat_decl);
4523           }
4524
4525   /* Here we elaborate everything we deferred above except for package bodies,
4526      which are elaborated at their freeze nodes.  Note that we must also
4527      go inside things (package specs and freeze nodes) the first pass did.  */
4528   if (pass2p)
4529     for (i = 0; i <= 1; i++)
4530       if (Present (gnat_decl_array[i]))
4531         for (gnat_decl = First (gnat_decl_array[i]);
4532              gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4533           {
4534             if (Nkind (gnat_decl) == N_Subprogram_Body
4535                 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
4536                 || Nkind (gnat_decl) == N_Task_Body_Stub
4537                 || Nkind (gnat_decl) == N_Protected_Body_Stub)
4538               gnat_to_code (gnat_decl);
4539
4540             else if (Nkind (gnat_decl) == N_Package_Declaration
4541                      && (Nkind (Specification (gnat_decl)
4542                                 == N_Package_Specification)))
4543               process_decls (Visible_Declarations (Specification (gnat_decl)),
4544                              Private_Declarations (Specification (gnat_decl)),
4545                              Empty, 0, 1);
4546
4547             else if (Nkind (gnat_decl) == N_Freeze_Entity)
4548               process_decls (Actions (gnat_decl), Empty, Empty, 0, 1);
4549           }
4550 }
4551 \f
4552 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4553    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4554    which we have to check. */
4555
4556 static tree
4557 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
4558 {
4559   tree gnu_range_type = get_unpadded_type (gnat_range_type);
4560   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
4561   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4562   tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
4563
4564   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4565      we can't do anything since we might be truncating the bounds.  No
4566      check is needed in this case.  */
4567   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
4568       && (TYPE_PRECISION (gnu_compare_type)
4569           < TYPE_PRECISION (get_base_type (gnu_range_type))))
4570     return gnu_expr;
4571
4572   /* Checked expressions must be evaluated only once. */
4573   gnu_expr = protect_multiple_eval (gnu_expr);
4574
4575   /* There's no good type to use here, so we might as well use
4576      integer_type_node. Note that the form of the check is
4577         (not (expr >= lo)) or (not (expr >= hi))
4578       the reason for this slightly convoluted form is that NaN's
4579       are not considered to be in range in the float case. */
4580   return emit_check
4581     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4582                       invert_truthvalue
4583                       (build_binary_op (GE_EXPR, integer_type_node,
4584                                        convert (gnu_compare_type, gnu_expr),
4585                                        convert (gnu_compare_type, gnu_low))),
4586                       invert_truthvalue
4587                       (build_binary_op (LE_EXPR, integer_type_node,
4588                                         convert (gnu_compare_type, gnu_expr),
4589                                         convert (gnu_compare_type,
4590                                                  gnu_high)))),
4591      gnu_expr, CE_Range_Check_Failed);
4592 }
4593 \f
4594 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4595    which we are about to index, GNU_EXPR is the index expression to be
4596    checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4597    against which GNU_EXPR has to be checked. Note that for index
4598    checking we cannot use the emit_range_check function (although very
4599    similar code needs to be generated in both cases) since for index
4600    checking the array type against which we are checking the indeces
4601    may be unconstrained and consequently we need to retrieve the
4602    actual index bounds from the array object itself
4603    (GNU_ARRAY_OBJECT). The place where we need to do that is in
4604    subprograms having unconstrained array formal parameters */
4605
4606 static tree
4607 emit_index_check (tree gnu_array_object,
4608                   tree gnu_expr,
4609                   tree gnu_low,
4610                   tree gnu_high)
4611 {
4612   tree gnu_expr_check;
4613
4614   /* Checked expressions must be evaluated only once. */
4615   gnu_expr = protect_multiple_eval (gnu_expr);
4616
4617   /* Must do this computation in the base type in case the expression's
4618      type is an unsigned subtypes.  */
4619   gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
4620
4621   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4622      the object we are handling. */
4623   gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
4624   gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
4625
4626   /* There's no good type to use here, so we might as well use
4627      integer_type_node.   */
4628   return emit_check
4629     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4630                       build_binary_op (LT_EXPR, integer_type_node,
4631                                        gnu_expr_check,
4632                                        convert (TREE_TYPE (gnu_expr_check),
4633                                                 gnu_low)),
4634                       build_binary_op (GT_EXPR, integer_type_node,
4635                                        gnu_expr_check,
4636                                        convert (TREE_TYPE (gnu_expr_check),
4637                                                 gnu_high))),
4638      gnu_expr, CE_Index_Check_Failed);
4639 }
4640 \f
4641 /* Given GNU_COND which contains the condition corresponding to an access,
4642    discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4643    that returns GNU_EXPR if GNU_COND is false and raises a
4644    CONSTRAINT_ERROR if GNU_COND is true.  REASON is the code that says
4645    why the exception was raised.  */
4646
4647 static tree
4648 emit_check (tree gnu_cond, tree gnu_expr, int reason)
4649 {
4650   tree gnu_call;
4651   tree gnu_result;
4652
4653   gnu_call = build_call_raise (reason);
4654
4655   /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
4656      in front of the comparison in case it ends up being a SAVE_EXPR.  Put the
4657      whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
4658      out.  */
4659   gnu_result = fold (build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
4660                             build (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
4661                                    gnu_call, gnu_expr),
4662                             gnu_expr));
4663
4664   /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
4665      protect it.  Otherwise, show GNU_RESULT has no side effects: we
4666      don't need to evaluate it just for the check.  */
4667   if (TREE_SIDE_EFFECTS (gnu_expr))
4668     gnu_result
4669       = build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
4670   else
4671     TREE_SIDE_EFFECTS (gnu_result) = 0;
4672
4673   /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
4674      we will repeatedly do the test.  It would be nice if GCC was able
4675      to optimize this and only do it once.  */
4676   return save_expr (gnu_result);
4677 }
4678 \f
4679 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4680    overflow checks if OVERFLOW_P is nonzero and range checks if
4681    RANGE_P is nonzero.  GNAT_TYPE is known to be an integral type.
4682    If TRUNCATE_P is nonzero, do a float to integer conversion with
4683    truncation; otherwise round.  */
4684
4685 static tree
4686 convert_with_check (Entity_Id gnat_type,
4687                     tree gnu_expr,
4688                     int overflow_p,
4689                     int range_p,
4690                     int truncate_p)
4691 {
4692   tree gnu_type = get_unpadded_type (gnat_type);
4693   tree gnu_in_type = TREE_TYPE (gnu_expr);
4694   tree gnu_in_basetype = get_base_type (gnu_in_type);
4695   tree gnu_base_type = get_base_type (gnu_type);
4696   tree gnu_ada_base_type = get_ada_base_type (gnu_type);
4697   tree gnu_result = gnu_expr;
4698
4699   /* If we are not doing any checks, the output is an integral type, and
4700      the input is not a floating type, just do the conversion.  This
4701      shortcut is required to avoid problems with packed array types
4702      and simplifies code in all cases anyway.   */
4703   if (! range_p && ! overflow_p && INTEGRAL_TYPE_P (gnu_base_type)
4704       && ! FLOAT_TYPE_P (gnu_in_type))
4705     return convert (gnu_type, gnu_expr);
4706
4707   /* First convert the expression to its base type.  This
4708      will never generate code, but makes the tests below much simpler.
4709      But don't do this if converting from an integer type to an unconstrained
4710      array type since then we need to get the bounds from the original
4711      (unpacked) type.  */
4712   if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
4713     gnu_result = convert (gnu_in_basetype, gnu_result);
4714
4715   /* If overflow checks are requested,  we need to be sure the result will
4716      fit in the output base type.  But don't do this if the input
4717      is integer and the output floating-point.  */
4718   if (overflow_p
4719       && ! (FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
4720     {
4721       /* Ensure GNU_EXPR only gets evaluated once.  */
4722       tree gnu_input = protect_multiple_eval (gnu_result);
4723       tree gnu_cond = integer_zero_node;
4724       tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
4725       tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
4726       tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
4727       tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
4728
4729       /* Convert the lower bounds to signed types, so we're sure we're
4730          comparing them properly.  Likewise, convert the upper bounds
4731          to unsigned types.  */
4732       if (INTEGRAL_TYPE_P (gnu_in_basetype) && TREE_UNSIGNED (gnu_in_basetype))
4733         gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
4734
4735       if (INTEGRAL_TYPE_P (gnu_in_basetype)
4736           && ! TREE_UNSIGNED (gnu_in_basetype))
4737         gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
4738
4739       if (INTEGRAL_TYPE_P (gnu_base_type) && TREE_UNSIGNED (gnu_base_type))
4740         gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
4741
4742       if (INTEGRAL_TYPE_P (gnu_base_type) && ! TREE_UNSIGNED (gnu_base_type))
4743         gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
4744
4745       /* Check each bound separately and only if the result bound
4746          is tighter than the bound on the input type.  Note that all the
4747          types are base types, so the bounds must be constant. Also,
4748          the comparison is done in the base type of the input, which
4749          always has the proper signedness.  First check for input
4750          integer (which means output integer), output float (which means
4751          both float), or mixed, in which case we always compare.
4752          Note that we have to do the comparison which would *fail* in the
4753          case of an error since if it's an FP comparison and one of the
4754          values is a NaN or Inf, the comparison will fail.  */
4755       if (INTEGRAL_TYPE_P (gnu_in_basetype)
4756           ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
4757           : (FLOAT_TYPE_P (gnu_base_type)
4758              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
4759                                  TREE_REAL_CST (gnu_out_lb))
4760              : 1))
4761         gnu_cond
4762           = invert_truthvalue
4763             (build_binary_op (GE_EXPR, integer_type_node,
4764                               gnu_input, convert (gnu_in_basetype,
4765                                                   gnu_out_lb)));
4766
4767       if (INTEGRAL_TYPE_P (gnu_in_basetype)
4768           ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
4769           : (FLOAT_TYPE_P (gnu_base_type)
4770              ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
4771                                  TREE_REAL_CST (gnu_in_lb))
4772              : 1))
4773         gnu_cond
4774           = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
4775                              invert_truthvalue
4776                              (build_binary_op (LE_EXPR, integer_type_node,
4777                                                gnu_input,
4778                                                convert (gnu_in_basetype,
4779                                                         gnu_out_ub))));
4780
4781       if (! integer_zerop (gnu_cond))
4782         gnu_result = emit_check (gnu_cond, gnu_input,
4783                                  CE_Overflow_Check_Failed);
4784     }
4785
4786   /* Now convert to the result base type.  If this is a non-truncating
4787      float-to-integer conversion, round.  */
4788   if (INTEGRAL_TYPE_P (gnu_ada_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
4789       && ! truncate_p)
4790     {
4791       tree gnu_point_5 = build_real (gnu_in_basetype, dconstp5);
4792       tree gnu_minus_point_5 = build_real (gnu_in_basetype, dconstmp5);
4793       tree gnu_zero = convert (gnu_in_basetype, integer_zero_node);
4794       tree gnu_saved_result = save_expr (gnu_result);
4795       tree gnu_comp = build (GE_EXPR, integer_type_node,
4796                              gnu_saved_result, gnu_zero);
4797       tree gnu_adjust = build (COND_EXPR, gnu_in_basetype, gnu_comp,
4798                                gnu_point_5, gnu_minus_point_5);
4799
4800       gnu_result
4801         = build (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
4802     }
4803
4804   if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
4805       && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type)
4806       && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
4807     gnu_result = unchecked_convert (gnu_ada_base_type, gnu_result, 0);
4808   else
4809     gnu_result = convert (gnu_ada_base_type, gnu_result);
4810
4811   /* Finally, do the range check if requested.  Note that if the
4812      result type is a modular type, the range check is actually
4813      an overflow check.  */
4814
4815   if (range_p
4816       || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
4817           && TYPE_MODULAR_P (gnu_base_type) && overflow_p))
4818     gnu_result = emit_range_check (gnu_result, gnat_type);
4819
4820   return convert (gnu_type, gnu_result);
4821 }
4822 \f
4823 /* Return 1 if GNU_EXPR can be directly addressed.  This is the case unless
4824    it is an expression involving computation or if it involves a bitfield
4825    reference.  This returns the same as gnat_mark_addressable in most
4826    cases.  */
4827
4828 static int
4829 addressable_p (tree gnu_expr)
4830 {
4831   switch (TREE_CODE (gnu_expr))
4832     {
4833     case VAR_DECL:
4834     case PARM_DECL:
4835     case FUNCTION_DECL:
4836     case RESULT_DECL:
4837       /* All DECLs are addressable: if they are in a register, we can force
4838          them to memory.  */
4839       return 1;
4840
4841     case UNCONSTRAINED_ARRAY_REF:
4842     case INDIRECT_REF:
4843     case CONSTRUCTOR:
4844     case NULL_EXPR:
4845     case SAVE_EXPR:
4846       return 1;
4847
4848     case COMPONENT_REF:
4849       return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
4850               && (! DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr, 1))
4851                   || ! flag_strict_aliasing)
4852               && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4853
4854     case ARRAY_REF:  case ARRAY_RANGE_REF:
4855     case REALPART_EXPR:  case IMAGPART_EXPR:
4856     case NOP_EXPR:
4857       return addressable_p (TREE_OPERAND (gnu_expr, 0));
4858
4859     case CONVERT_EXPR:
4860       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
4861               && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4862
4863     case VIEW_CONVERT_EXPR:
4864       {
4865         /* This is addressable if we can avoid a copy.  */
4866         tree type = TREE_TYPE (gnu_expr);
4867         tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
4868
4869         return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
4870                   && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
4871                       || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
4872                  || ((TYPE_MODE (type) == BLKmode
4873                       || TYPE_MODE (inner_type) == BLKmode)
4874                      && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
4875                          || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
4876                          || TYPE_ALIGN_OK (type)
4877                          || TYPE_ALIGN_OK (inner_type))))
4878                 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4879       }
4880
4881     default:
4882       return 0;
4883     }
4884 }
4885 \f
4886 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
4887    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
4888    make a GCC type for GNAT_ENTITY and set up the correspondance.  */
4889
4890 void
4891 process_type (Entity_Id gnat_entity)
4892 {
4893   tree gnu_old
4894     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4895   tree gnu_new;
4896
4897   /* If we are to delay elaboration of this type, just do any
4898      elaborations needed for expressions within the declaration and
4899      make a dummy type entry for this node and its Full_View (if
4900      any) in case something points to it.  Don't do this if it
4901      has already been done (the only way that can happen is if
4902      the private completion is also delayed).  */
4903   if (Present (Freeze_Node (gnat_entity))
4904       || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4905           && Present (Full_View (gnat_entity))
4906           && Freeze_Node (Full_View (gnat_entity))
4907           && ! present_gnu_tree (Full_View (gnat_entity))))
4908     {
4909       elaborate_entity (gnat_entity);
4910
4911       if (gnu_old == 0)
4912         {
4913           tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
4914                                             make_dummy_type (gnat_entity),
4915                                             0, 0, 0);
4916
4917           save_gnu_tree (gnat_entity, gnu_decl, 0);
4918           if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4919               && Present (Full_View (gnat_entity)))
4920             save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
4921         }
4922
4923       return;
4924     }
4925
4926   /* If we saved away a dummy type for this node it means that this
4927      made the type that corresponds to the full type of an incomplete
4928      type.  Clear that type for now and then update the type in the
4929      pointers.  */
4930   if (gnu_old != 0)
4931     {
4932       if (TREE_CODE (gnu_old) != TYPE_DECL
4933           || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
4934         {
4935           /* If this was a withed access type, this is not an error
4936              and merely indicates we've already elaborated the type
4937              already. */
4938           if (Is_Type (gnat_entity) && From_With_Type (gnat_entity))
4939             return;
4940
4941           gigi_abort (323);
4942         }
4943
4944       save_gnu_tree (gnat_entity, NULL_TREE, 0);
4945     }
4946
4947   /* Now fully elaborate the type.  */
4948   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
4949   if (TREE_CODE (gnu_new) != TYPE_DECL)
4950     gigi_abort (324);
4951
4952   /* If we have an old type and we've made pointers to this type,
4953      update those pointers.  */
4954   if (gnu_old != 0)
4955     update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4956                        TREE_TYPE (gnu_new));
4957
4958   /* If this is a record type corresponding to a task or protected type
4959      that is a completion of an incomplete type, perform a similar update
4960      on the type.  */
4961   /* ??? Including protected types here is a guess. */
4962
4963   if (IN (Ekind (gnat_entity), Record_Kind)
4964       && Is_Concurrent_Record_Type (gnat_entity)
4965       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
4966     {
4967       tree gnu_task_old
4968         = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
4969
4970       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
4971                      NULL_TREE, 0);
4972       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
4973                      gnu_new, 0);
4974
4975       update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
4976                          TREE_TYPE (gnu_new));
4977     }
4978 }
4979 \f
4980 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
4981    GNU_TYPE is the GCC type of the corresponding record.
4982
4983    Return a CONSTRUCTOR to build the record.  */
4984
4985 static tree
4986 assoc_to_constructor (Node_Id gnat_assoc, tree gnu_type)
4987 {
4988   tree gnu_field, gnu_list, gnu_result;
4989
4990   /* We test for GNU_FIELD being empty in the case where a variant
4991      was the last thing since we don't take things off GNAT_ASSOC in
4992      that case.  We check GNAT_ASSOC in case we have a variant, but it
4993      has no fields.  */
4994
4995   for (gnu_list = NULL_TREE; Present (gnat_assoc);
4996        gnat_assoc = Next (gnat_assoc))
4997     {
4998       Node_Id gnat_field = First (Choices (gnat_assoc));
4999       tree gnu_field = gnat_to_gnu_entity (Entity (gnat_field), NULL_TREE, 0);
5000       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
5001
5002       /* The expander is supposed to put a single component selector name
5003          in every record component association */
5004       if (Next (gnat_field))
5005         gigi_abort (328);
5006
5007       /* Before assigning a value in an aggregate make sure range checks
5008          are done if required.  Then convert to the type of the field.  */
5009       if (Do_Range_Check (Expression (gnat_assoc)))
5010         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
5011
5012       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
5013
5014       /* Add the field and expression to the list.  */
5015       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
5016     }
5017
5018   gnu_result = extract_values (gnu_list, gnu_type);
5019
5020   /* Verify every enty in GNU_LIST was used.  */
5021   for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
5022     if (! TREE_ADDRESSABLE (gnu_field))
5023       gigi_abort (311);
5024
5025   return gnu_result;
5026 }
5027
5028 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
5029    is the first element of an array aggregate. It may itself be an
5030    aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
5031    corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
5032    of the array component. It is needed for range checking. */
5033
5034 static tree
5035 pos_to_constructor (Node_Id gnat_expr,
5036                     tree gnu_array_type,
5037                     Entity_Id gnat_component_type)
5038 {
5039   tree gnu_expr;
5040   tree gnu_expr_list = NULL_TREE;
5041
5042   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
5043     {
5044       /* If the expression is itself an array aggregate then first build the
5045          innermost constructor if it is part of our array (multi-dimensional
5046          case).  */
5047
5048       if (Nkind (gnat_expr) == N_Aggregate
5049           && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
5050           && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
5051         gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
5052                                        TREE_TYPE (gnu_array_type),
5053                                        gnat_component_type);
5054       else
5055         {
5056           gnu_expr = gnat_to_gnu (gnat_expr);
5057
5058           /* before assigning the element to the array make sure it is
5059              in range */
5060           if (Do_Range_Check (gnat_expr))
5061             gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
5062         }
5063
5064       gnu_expr_list
5065         = tree_cons (NULL_TREE, convert (TREE_TYPE (gnu_array_type), gnu_expr),
5066                      gnu_expr_list);
5067     }
5068
5069   return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
5070 }
5071 \f
5072 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5073    some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
5074    of the associations that are from RECORD_TYPE.  If we see an internal
5075    record, make a recursive call to fill it in as well.  */
5076
5077 static tree
5078 extract_values (tree values, tree record_type)
5079 {
5080   tree result = NULL_TREE;
5081   tree field, tem;
5082
5083   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
5084     {
5085       tree value = 0;
5086
5087       /* _Parent is an internal field, but may have values in the aggregate,
5088          so check for values first.  */
5089       if ((tem = purpose_member (field, values)) != 0)
5090         {
5091           value = TREE_VALUE (tem);
5092           TREE_ADDRESSABLE (tem) = 1;
5093         }
5094
5095       else if (DECL_INTERNAL_P (field))
5096         {
5097           value = extract_values (values, TREE_TYPE (field));
5098           if (TREE_CODE (value) == CONSTRUCTOR
5099               && CONSTRUCTOR_ELTS (value) == 0)
5100             value = 0;
5101         }
5102       else
5103         /* If we have a record subtype, the names will match, but not the
5104            actual FIELD_DECLs.  */
5105         for (tem = values; tem; tem = TREE_CHAIN (tem))
5106           if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
5107             {
5108               value = convert (TREE_TYPE (field), TREE_VALUE (tem));
5109               TREE_ADDRESSABLE (tem) = 1;
5110             }
5111
5112       if (value == 0)
5113         continue;
5114
5115       result = tree_cons (field, value, result);
5116     }
5117
5118   return gnat_build_constructor (record_type, nreverse (result));
5119 }
5120 \f
5121 /* EXP is to be treated as an array or record.  Handle the cases when it is
5122    an access object and perform the required dereferences.  */
5123
5124 static tree
5125 maybe_implicit_deref (tree exp)
5126 {
5127   /* If the type is a pointer, dereference it.  */
5128
5129   if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
5130     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
5131
5132   /* If we got a padded type, remove it too.  */
5133   if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
5134       && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
5135     exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
5136
5137   return exp;
5138 }
5139 \f
5140 /* Protect EXP from multiple evaluation.  This may make a SAVE_EXPR.  */
5141
5142 tree
5143 protect_multiple_eval (tree exp)
5144 {
5145   tree type = TREE_TYPE (exp);
5146
5147   /* If this has no side effects, we don't need to do anything.  */
5148   if (! TREE_SIDE_EFFECTS (exp))
5149     return exp;
5150
5151   /* If it is a conversion, protect what's inside the conversion.
5152      Similarly, if we're indirectly referencing something, we only
5153      actually need to protect the address since the data itself can't
5154      change in these situations.  */
5155   else if (TREE_CODE (exp) == NON_LVALUE_EXPR
5156            || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR
5157            || TREE_CODE (exp) == VIEW_CONVERT_EXPR
5158            || TREE_CODE (exp) == INDIRECT_REF
5159            || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
5160     return build1 (TREE_CODE (exp), type,
5161                    protect_multiple_eval (TREE_OPERAND (exp, 0)));
5162
5163   /* If EXP is a fat pointer or something that can be placed into a register,
5164      just make a SAVE_EXPR.  */
5165   if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
5166     return save_expr (exp);
5167
5168   /* Otherwise, dereference, protect the address, and re-reference.  */
5169   else
5170     return
5171       build_unary_op (INDIRECT_REF, type,
5172                       save_expr (build_unary_op (ADDR_EXPR,
5173                                                  build_reference_type (type),
5174                                                  exp)));
5175 }
5176 \f
5177 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5178    how to handle our new nodes and we take an extra argument that says
5179    whether to force evaluation of everything.  */
5180
5181 tree
5182 gnat_stabilize_reference (tree ref, int force)
5183 {
5184   tree type = TREE_TYPE (ref);
5185   enum tree_code code = TREE_CODE (ref);
5186   tree result;
5187
5188   switch (code)
5189     {
5190     case VAR_DECL:
5191     case PARM_DECL:
5192     case RESULT_DECL:
5193       /* No action is needed in this case.  */
5194       return ref;
5195
5196     case NOP_EXPR:
5197     case CONVERT_EXPR:
5198     case FLOAT_EXPR:
5199     case FIX_TRUNC_EXPR:
5200     case FIX_FLOOR_EXPR:
5201     case FIX_ROUND_EXPR:
5202     case FIX_CEIL_EXPR:
5203     case VIEW_CONVERT_EXPR:
5204     case ADDR_EXPR:
5205       result
5206         = build1 (code, type,
5207                   gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
5208       break;
5209
5210     case INDIRECT_REF:
5211     case UNCONSTRAINED_ARRAY_REF:
5212       result = build1 (code, type,
5213                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5214                                                    force));
5215       break;
5216
5217     case COMPONENT_REF:
5218       result = build (COMPONENT_REF, type,
5219                       gnat_stabilize_reference (TREE_OPERAND (ref, 0),
5220                                                 force),
5221                       TREE_OPERAND (ref, 1));
5222       break;
5223
5224     case BIT_FIELD_REF:
5225       result = build (BIT_FIELD_REF, type,
5226                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5227                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5228                                                      force),
5229                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
5230                                                   force));
5231       break;
5232
5233     case ARRAY_REF:
5234       result = build (ARRAY_REF, type,
5235                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5236                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5237                                                   force));
5238       break;
5239
5240     case ARRAY_RANGE_REF:
5241       result = build (ARRAY_RANGE_REF, type,
5242                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5243                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5244                                                   force));
5245       break;
5246
5247     case COMPOUND_EXPR:
5248       result = build (COMPOUND_EXPR, type,
5249                       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5250                                                   force),
5251                       gnat_stabilize_reference (TREE_OPERAND (ref, 1),
5252                                                 force));
5253       break;
5254
5255     case RTL_EXPR:
5256       result = build1 (INDIRECT_REF, type,
5257                        save_expr (build1 (ADDR_EXPR,
5258                                           build_reference_type (type), ref)));
5259       break;
5260
5261       /* If arg isn't a kind of lvalue we recognize, make no change.
5262          Caller should recognize the error for an invalid lvalue.  */
5263     default:
5264       return ref;
5265
5266     case ERROR_MARK:
5267       return error_mark_node;
5268     }
5269
5270   TREE_READONLY (result) = TREE_READONLY (ref);
5271   return result;
5272 }
5273
5274 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5275    arg to force a SAVE_EXPR for everything.  */
5276
5277 static tree
5278 gnat_stabilize_reference_1 (tree e, int force)
5279 {
5280   enum tree_code code = TREE_CODE (e);
5281   tree type = TREE_TYPE (e);
5282   tree result;
5283
5284   /* We cannot ignore const expressions because it might be a reference
5285      to a const array but whose index contains side-effects.  But we can
5286      ignore things that are actual constant or that already have been
5287      handled by this function.  */
5288
5289   if (TREE_CONSTANT (e) || code == SAVE_EXPR)
5290     return e;
5291
5292   switch (TREE_CODE_CLASS (code))
5293     {
5294     case 'x':
5295     case 't':
5296     case 'd':
5297     case 'b':
5298     case '<':
5299     case 's':
5300     case 'e':
5301     case 'r':
5302       if (TREE_SIDE_EFFECTS (e) || force)
5303         return save_expr (e);
5304       return e;
5305
5306     case 'c':
5307       /* Constants need no processing.  In fact, we should never reach
5308          here.  */
5309       return e;
5310
5311     case '2':
5312       /* Recursively stabilize each operand.  */
5313       result = build (code, type,
5314                       gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
5315                       gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
5316       break;
5317
5318     case '1':
5319       /* Recursively stabilize each operand.  */
5320       result = build1 (code, type,
5321                        gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
5322                                                    force));
5323       break;
5324
5325     default:
5326       abort ();
5327     }
5328
5329   TREE_READONLY (result) = TREE_READONLY (e);
5330   return result;
5331 }
5332 \f
5333 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5334    either a spec or a body, BODY_P says which.  If needed, make a function
5335    to be the elaboration routine for that object and perform the elaborations
5336    in GNU_ELAB_LIST.
5337
5338    Return 1 if we didn't need an elaboration function, zero otherwise.  */
5339
5340 static int
5341 build_unit_elab (Entity_Id gnat_unit, int body_p, tree gnu_elab_list)
5342 {
5343   tree gnu_decl;
5344   rtx insn;
5345   int result = 1;
5346
5347   /* If we have nothing to do, return.  */
5348   if (gnu_elab_list == 0)
5349     return 1;
5350
5351   /* Prevent the elaboration list from being reclaimed by the GC.  */
5352   gnu_pending_elaboration_lists = chainon (gnu_pending_elaboration_lists,
5353                                            gnu_elab_list);
5354
5355   /* Set our file and line number to that of the object and set up the
5356      elaboration routine.  */
5357   gnu_decl = create_subprog_decl (create_concat_name (gnat_unit,
5358                                                       body_p ?
5359                                                       "elabb" : "elabs"),
5360                                   NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0,
5361                                   0);
5362   DECL_ELABORATION_PROC_P (gnu_decl) = 1;
5363
5364   begin_subprog_body (gnu_decl);
5365   set_lineno (gnat_unit, 1);
5366   pushlevel (0);
5367   gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
5368   expand_start_bindings (0);
5369
5370   /* Emit the assignments for the elaborations we have to do.  If there
5371      is no destination, this is just a call to execute some statement
5372      that was placed within the declarative region.   But first save a
5373      pointer so we can see if any insns were generated.  */
5374
5375   insn = get_last_insn ();
5376
5377   for (; gnu_elab_list; gnu_elab_list = TREE_CHAIN (gnu_elab_list))
5378     if (TREE_PURPOSE (gnu_elab_list) == NULL_TREE)
5379       {
5380         if (TREE_VALUE (gnu_elab_list) != 0)
5381           expand_expr_stmt (TREE_VALUE (gnu_elab_list));
5382       }
5383     else
5384       {
5385         tree lhs = TREE_PURPOSE (gnu_elab_list);
5386
5387         input_location = DECL_SOURCE_LOCATION (lhs);
5388
5389         /* If LHS has a padded type, convert it to the unpadded type
5390            so the assignment is done properly.  */
5391         if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
5392             && TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
5393           lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
5394
5395         emit_line_note (input_location);
5396         expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
5397                                            TREE_PURPOSE (gnu_elab_list),
5398                                            TREE_VALUE (gnu_elab_list)));
5399       }
5400
5401   /* See if any non-NOTE insns were generated.  */
5402   for (insn = NEXT_INSN (insn); insn; insn = NEXT_INSN (insn))
5403     if (GET_RTX_CLASS (GET_CODE (insn)) == RTX_INSN)
5404       {
5405         result = 0;
5406         break;
5407       }
5408
5409   expand_end_bindings (getdecls (), kept_level_p (), -1);
5410   poplevel (kept_level_p (), 1, 0);
5411   gnu_block_stack = TREE_CHAIN (gnu_block_stack);
5412   end_subprog_body ();
5413
5414   /* We are finished with the elaboration list it can now be discarded.  */
5415   gnu_pending_elaboration_lists = TREE_CHAIN (gnu_pending_elaboration_lists);
5416
5417   /* If there were no insns, we don't need an elab routine.  It would
5418      be nice to not output this one, but there's no good way to do that.  */
5419   return result;
5420 }
5421 \f
5422 extern char *__gnat_to_canonical_file_spec (char *);
5423
5424 /* Determine the input_filename and the input_line from the source location
5425    (Sloc) of GNAT_NODE node.  Set the global variable input_filename and
5426    input_line.  If WRITE_NOTE_P is true, emit a line number note.  */
5427
5428 void
5429 set_lineno (Node_Id gnat_node, int write_note_p)
5430 {
5431   Source_Ptr source_location = Sloc (gnat_node);
5432
5433   set_lineno_from_sloc (source_location, write_note_p);
5434 }
5435
5436 /* Likewise, but passed a Sloc.  */
5437
5438 void
5439 set_lineno_from_sloc (Source_Ptr source_location, int write_note_p)
5440 {
5441   /* If node not from source code, ignore.  */
5442   if (source_location < 0)
5443     return;
5444
5445   /* Use the identifier table to make a hashed, permanent copy of the filename,
5446      since the name table gets reallocated after Gigi returns but before all
5447      the debugging information is output. The __gnat_to_canonical_file_spec
5448      call translates filenames from pragmas Source_Reference that contain host
5449      style syntax not understood by gdb. */
5450   input_filename
5451     = IDENTIFIER_POINTER
5452       (get_identifier
5453        (__gnat_to_canonical_file_spec
5454         (Get_Name_String
5455          (Full_Debug_Name (Get_Source_File_Index (source_location))))));
5456
5457   /* ref_filename is the reference file name as given by sinput (i.e no
5458      directory) */
5459   ref_filename
5460     = IDENTIFIER_POINTER
5461       (get_identifier
5462        (Get_Name_String
5463         (Debug_Source_Name (Get_Source_File_Index (source_location)))));;
5464   input_line = Get_Logical_Line_Number (source_location);
5465
5466   if (write_note_p)
5467     emit_line_note (input_location);
5468 }
5469 \f
5470 /* Post an error message.  MSG is the error message, properly annotated.
5471    NODE is the node at which to post the error and the node to use for the
5472    "&" substitution.  */
5473
5474 void
5475 post_error (const char *msg, Node_Id node)
5476 {
5477   String_Template temp;
5478   Fat_Pointer fp;
5479
5480   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5481   fp.Array = msg, fp.Bounds = &temp;
5482   if (Present (node))
5483     Error_Msg_N (fp, node);
5484 }
5485
5486 /* Similar, but NODE is the node at which to post the error and ENT
5487    is the node to use for the "&" substitution.  */
5488
5489 void
5490 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
5491 {
5492   String_Template temp;
5493   Fat_Pointer fp;
5494
5495   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5496   fp.Array = msg, fp.Bounds = &temp;
5497   if (Present (node))
5498     Error_Msg_NE (fp, node, ent);
5499 }
5500
5501 /* Similar, but NODE is the node at which to post the error, ENT is the node
5502    to use for the "&" substitution, and N is the number to use for the ^.  */
5503
5504 void
5505 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
5506 {
5507   String_Template temp;
5508   Fat_Pointer fp;
5509
5510   temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5511   fp.Array = msg, fp.Bounds = &temp;
5512   Error_Msg_Uint_1 = UI_From_Int (n);
5513
5514   if (Present (node))
5515     Error_Msg_NE (fp, node, ent);
5516 }
5517 \f
5518 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5519    number to write.  If the tree represents a constant that fits within
5520    a host integer, the text inside curly brackets in MSG will be output
5521    (presumably including a '^').  Otherwise that text will not be output
5522    and the text inside square brackets will be output instead.  */
5523
5524 void
5525 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
5526 {
5527   char *newmsg = alloca (strlen (msg) + 1);
5528   String_Template temp = {1, 0};
5529   Fat_Pointer fp;
5530   char start_yes, end_yes, start_no, end_no;
5531   const char *p;
5532   char *q;
5533
5534   fp.Array = newmsg, fp.Bounds = &temp;
5535
5536   if (host_integerp (t, 1)
5537 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5538       &&
5539       compare_tree_int
5540       (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
5541 #endif
5542       )
5543     {
5544       Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
5545       start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
5546     }
5547   else
5548     start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
5549
5550   for (p = msg, q = newmsg; *p != 0; p++)
5551     {
5552       if (*p == start_yes)
5553         for (p++; *p != end_yes; p++)
5554           *q++ = *p;
5555       else if (*p == start_no)
5556         for (p++; *p != end_no; p++)
5557           ;
5558       else
5559         *q++ = *p;
5560     }
5561
5562   *q = 0;
5563
5564   temp.High_Bound = strlen (newmsg);
5565   if (Present (node))
5566     Error_Msg_NE (fp, node, ent);
5567 }
5568
5569 /* Similar to post_error_ne_tree, except that NUM is a second
5570    integer to write in the message.  */
5571
5572 void
5573 post_error_ne_tree_2 (const char *msg,
5574                       Node_Id node,
5575                       Entity_Id ent,
5576                       tree t,
5577                       int num)
5578 {
5579   Error_Msg_Uint_2 = UI_From_Int (num);
5580   post_error_ne_tree (msg, node, ent, t);
5581 }
5582
5583 /* Set the node for a second '&' in the error message.  */
5584
5585 void
5586 set_second_error_entity (Entity_Id e)
5587 {
5588   Error_Msg_Node_2 = e;
5589 }
5590 \f
5591 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5592    as the relevant node that provides the location info for the error */
5593
5594 void
5595 gigi_abort (int code)
5596 {
5597   String_Template temp = {1, 10};
5598   Fat_Pointer fp;
5599
5600   fp.Array = "Gigi abort", fp.Bounds = &temp;
5601
5602   Current_Error_Node = error_gnat_node;
5603   Compiler_Abort (fp, code);
5604 }
5605 \f
5606 /* Initialize the table that maps GNAT codes to GCC codes for simple
5607    binary and unary operations.  */
5608
5609 void
5610 init_code_table (void)
5611 {
5612   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
5613   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
5614
5615   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
5616   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
5617   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
5618   gnu_codes[N_Op_Eq] = EQ_EXPR;
5619   gnu_codes[N_Op_Ne] = NE_EXPR;
5620   gnu_codes[N_Op_Lt] = LT_EXPR;
5621   gnu_codes[N_Op_Le] = LE_EXPR;
5622   gnu_codes[N_Op_Gt] = GT_EXPR;
5623   gnu_codes[N_Op_Ge] = GE_EXPR;
5624   gnu_codes[N_Op_Add] = PLUS_EXPR;
5625   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
5626   gnu_codes[N_Op_Multiply] = MULT_EXPR;
5627   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
5628   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
5629   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
5630   gnu_codes[N_Op_Abs] = ABS_EXPR;
5631   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
5632   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
5633   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
5634   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
5635   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
5636   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
5637 }
5638
5639 #include "gt-ada-trans.h"