gcc/ada/trans.c

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