gcc/ada/trans.c

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