gcc/ada/trans.c

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