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