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