gcc/ada/gcc-interface/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-2010, 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 3,  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  COPYING3.  If not see *
  19  * <http://www.gnu.org/licenses/>.                                          *
  20  *                                                                          *
  21  * GNAT was originally developed  by the GNAT team at  New York University. *
  22  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  23  *                                                                          *
  24  ****************************************************************************/
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "tm.h"
  30 #include "tree.h"
  31 #include "flags.h"
  32 #include "expr.h"
  33 #include "ggc.h"
  34 #include "output.h"
  35 #include "tree-iterator.h"
  36 #include "gimple.h"
  37
  38 #include "ada.h"
  39 #include "adadecode.h"
  40 #include "types.h"
  41 #include "atree.h"
  42 #include "elists.h"
  43 #include "namet.h"
  44 #include "nlists.h"
  45 #include "snames.h"
  46 #include "stringt.h"
  47 #include "uintp.h"
  48 #include "urealp.h"
  49 #include "fe.h"
  50 #include "sinfo.h"
  51 #include "einfo.h"
  52 #include "ada-tree.h"
  53 #include "gigi.h"
  54
  55 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
  56    for fear of running out of stack space.  If we need more, we use xmalloc
  57    instead.  */
  58 #define ALLOCA_THRESHOLD 1000
  59
  60 /* Let code below know whether we are targetting VMS without need of
  61    intrusive preprocessor directives.  */
  62 #ifndef TARGET_ABI_OPEN_VMS
  63 #define TARGET_ABI_OPEN_VMS 0
  64 #endif
  65
  66 /* For efficient float-to-int rounding, it is necessary to know whether
  67    floating-point arithmetic may use wider intermediate results.  When
  68    FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
  69    that arithmetic does not widen if double precision is emulated.  */
  70 #ifndef FP_ARITH_MAY_WIDEN
  71 #if defined(HAVE_extendsfdf2)
  72 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
  73 #else
  74 #define FP_ARITH_MAY_WIDEN 0
  75 #endif
  76 #endif
  77
  78 extern char *__gnat_to_canonical_file_spec (char *);
  79
  80 int max_gnat_nodes;
  81 int number_names;
  82 int number_files;
  83 struct Node *Nodes_Ptr;
  84 Node_Id *Next_Node_Ptr;
  85 Node_Id *Prev_Node_Ptr;
  86 struct Elist_Header *Elists_Ptr;
  87 struct Elmt_Item *Elmts_Ptr;
  88 struct String_Entry *Strings_Ptr;
  89 Char_Code *String_Chars_Ptr;
  90 struct List_Header *List_Headers_Ptr;
  91
  92 /* Current filename without path.  */
  93 const char *ref_filename;
  94
  95 /* True when gigi is being called on an analyzed but unexpanded
  96    tree, and the only purpose of the call is to properly annotate
  97    types with representation information.  */
  98 bool type_annotate_only;
  99
 100 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
 101    of unconstrained array IN parameters to avoid emitting a great deal of
 102    redundant instructions to recompute them each time.  */
 103 struct GTY (()) parm_attr_d {
 104   int id; /* GTY doesn't like Entity_Id.  */
 105   int dim;
 106   tree first;
 107   tree last;
 108   tree length;
 109 };
 110
 111 typedef struct parm_attr_d *parm_attr;
 112
 113 DEF_VEC_P(parm_attr);
 114 DEF_VEC_ALLOC_P(parm_attr,gc);
 115
 116 struct GTY(()) language_function {
 117   VEC(parm_attr,gc) *parm_attr_cache;
 118 };
 119
 120 #define f_parm_attr_cache \
 121   DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
 122
 123 /* A structure used to gather together information about a statement group.
 124    We use this to gather related statements, for example the "then" part
 125    of a IF.  In the case where it represents a lexical scope, we may also
 126    have a BLOCK node corresponding to it and/or cleanups.  */
 127
 128 struct GTY((chain_next ("%h.previous"))) stmt_group {
 129   struct stmt_group *previous;  /* Previous code group.  */
 130   tree stmt_list;               /* List of statements for this code group.  */
 131   tree block;                   /* BLOCK for this code group, if any.  */
 132   tree cleanups;                /* Cleanups for this code group, if any.  */
 133 };
 134
 135 static GTY(()) struct stmt_group *current_stmt_group;
 136
 137 /* List of unused struct stmt_group nodes.  */
 138 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
 139
 140 /* A structure used to record information on elaboration procedures
 141    we've made and need to process.
 142
 143    ??? gnat_node should be Node_Id, but gengtype gets confused.  */
 144
 145 struct GTY((chain_next ("%h.next"))) elab_info {
 146   struct elab_info *next;       /* Pointer to next in chain.  */
 147   tree elab_proc;               /* Elaboration procedure.  */
 148   int gnat_node;                /* The N_Compilation_Unit.  */
 149 };
 150
 151 static GTY(()) struct elab_info *elab_info_list;
 152
 153 /* Free list of TREE_LIST nodes used for stacks.  */
 154 static GTY((deletable)) tree gnu_stack_free_list;
 155
 156 /* List of TREE_LIST nodes representing a stack of exception pointer
 157    variables.  TREE_VALUE is the VAR_DECL that stores the address of
 158    the raised exception.  Nonzero means we are in an exception
 159    handler.  Not used in the zero-cost case.  */
 160 static GTY(()) tree gnu_except_ptr_stack;
 161
 162 /* List of TREE_LIST nodes used to store the current elaboration procedure
 163    decl.  TREE_VALUE is the decl.  */
 164 static GTY(()) tree gnu_elab_proc_stack;
 165
 166 /* Variable that stores a list of labels to be used as a goto target instead of
 167    a return in some functions.  See processing for N_Subprogram_Body.  */
 168 static GTY(()) tree gnu_return_label_stack;
 169
 170 /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes.
 171    TREE_VALUE of each entry is the label of the corresponding LOOP_STMT.  */
 172 static GTY(()) tree gnu_loop_label_stack;
 173
 174 /* List of TREE_LIST nodes representing labels for switch statements.
 175    TREE_VALUE of each entry is the label at the end of the switch.  */
 176 static GTY(()) tree gnu_switch_label_stack;
 177
 178 /* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label.  */
 179 static GTY(()) tree gnu_constraint_error_label_stack;
 180 static GTY(()) tree gnu_storage_error_label_stack;
 181 static GTY(()) tree gnu_program_error_label_stack;
 182
 183 /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
 184 static enum tree_code gnu_codes[Number_Node_Kinds];
 185
 186 /* Current node being treated, in case abort called.  */
 187 Node_Id error_gnat_node;
 188
 189 static void init_code_table (void);
 190 static void Compilation_Unit_to_gnu (Node_Id);
 191 static void record_code_position (Node_Id);
 192 static void insert_code_for (Node_Id);
 193 static void add_cleanup (tree, Node_Id);
 194 static tree unshare_save_expr (tree *, int *, void *);
 195 static void add_stmt_list (List_Id);
 196 static void push_exception_label_stack (tree *, Entity_Id);
 197 static tree build_stmt_group (List_Id, bool);
 198 static void push_stack (tree *, tree, tree);
 199 static void pop_stack (tree *);
 200 static enum gimplify_status gnat_gimplify_stmt (tree *);
 201 static void elaborate_all_entities (Node_Id);
 202 static void process_freeze_entity (Node_Id);
 203 static void process_inlined_subprograms (Node_Id);
 204 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
 205 static tree emit_range_check (tree, Node_Id, Node_Id);
 206 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
 207 static tree emit_check (tree, tree, int, Node_Id);
 208 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
 209 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
 210 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
 211 static bool smaller_packable_type_p (tree, tree);
 212 static bool addressable_p (tree, tree);
 213 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 214 static tree extract_values (tree, tree);
 215 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
 216 static tree maybe_implicit_deref (tree);
 217 static tree gnat_stabilize_reference (tree, bool);
 218 static tree gnat_stabilize_reference_1 (tree, bool);
 219 static void set_expr_location_from_node (tree, Node_Id);
 220 static int lvalue_required_p (Node_Id, tree, bool, bool);
 221
 222 /* Hooks for debug info back-ends, only supported and used in a restricted set
 223    of configurations.  */
 224 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
 225 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
 226 \f
 227 /* This is the main program of the back-end.  It sets up all the table
 228    structures and then generates code.  */
 229
 230 void
 231 gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
 232       struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
 233       struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
 234       struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
 235       struct List_Header *list_headers_ptr, Nat number_file,
 236       struct File_Info_Type *file_info_ptr, Entity_Id standard_boolean,
 237       Entity_Id standard_integer, Entity_Id standard_long_long_float,
 238       Entity_Id standard_exception_type, Int gigi_operating_mode)
 239 {
 240   Entity_Id gnat_literal;
 241   tree long_long_float_type, exception_type, t;
 242   tree int64_type = gnat_type_for_size (64, 0);
 243   struct elab_info *info;
 244   int i;
 245
 246   max_gnat_nodes = max_gnat_node;
 247   number_names = number_name;
 248   number_files = number_file;
 249   Nodes_Ptr = nodes_ptr;
 250   Next_Node_Ptr = next_node_ptr;
 251   Prev_Node_Ptr = prev_node_ptr;
 252   Elists_Ptr = elists_ptr;
 253   Elmts_Ptr = elmts_ptr;
 254   Strings_Ptr = strings_ptr;
 255   String_Chars_Ptr = string_chars_ptr;
 256   List_Headers_Ptr = list_headers_ptr;
 257
 258   type_annotate_only = (gigi_operating_mode == 1);
 259
 260   gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
 261
 262   /* Declare the name of the compilation unit as the first global
 263      name in order to make the middle-end fully deterministic.  */
 264   t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
 265   first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
 266
 267   for (i = 0; i < number_files; i++)
 268     {
 269       /* Use the identifier table to make a permanent copy of the filename as
 270          the name table gets reallocated after Gigi returns but before all the
 271          debugging information is output.  The __gnat_to_canonical_file_spec
 272          call translates filenames from pragmas Source_Reference that contain
 273          host style syntax not understood by gdb.  */
 274       const char *filename
 275         = IDENTIFIER_POINTER
 276            (get_identifier
 277             (__gnat_to_canonical_file_spec
 278              (Get_Name_String (file_info_ptr[i].File_Name))));
 279
 280       /* We rely on the order isomorphism between files and line maps.  */
 281       gcc_assert ((int) line_table->used == i);
 282
 283       /* We create the line map for a source file at once, with a fixed number
 284          of columns chosen to avoid jumping over the next power of 2.  */
 285       linemap_add (line_table, LC_ENTER, 0, filename, 1);
 286       linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
 287       linemap_position_for_column (line_table, 252 - 1);
 288       linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
 289     }
 290
 291   /* Initialize ourselves.  */
 292   init_code_table ();
 293   init_gnat_to_gnu ();
 294   init_dummy_type ();
 295
 296   /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
 297      errors.  */
 298   if (type_annotate_only)
 299     {
 300       TYPE_SIZE (void_type_node) = bitsize_zero_node;
 301       TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
 302     }
 303
 304   /* If the GNU type extensions to DWARF are available, setup the hooks.  */
 305 #if defined (DWARF2_DEBUGGING_INFO) && defined (DWARF2_GNU_TYPE_EXTENSIONS)
 306   /* We condition the name demangling and the generation of type encoding
 307      strings on -gdwarf+ and always set descriptive types on.  */
 308   if (use_gnu_debug_info_extensions)
 309     {
 310       dwarf2out_set_type_encoding_func (extract_encoding);
 311       dwarf2out_set_demangle_name_func (decode_name);
 312     }
 313   dwarf2out_set_descriptive_type_func (get_parallel_type);
 314 #endif
 315
 316   /* Enable GNAT stack checking method if needed */
 317   if (!Stack_Check_Probes_On_Target)
 318     set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
 319
 320   /* Retrieve alignment settings.  */
 321   double_float_alignment = get_target_double_float_alignment ();
 322   double_scalar_alignment = get_target_double_scalar_alignment ();
 323
 324   /* Record the builtin types.  Define `integer' and `unsigned char' first so
 325      that dbx will output them first.  */
 326   record_builtin_type ("integer", integer_type_node);
 327   record_builtin_type ("unsigned char", char_type_node);
 328   record_builtin_type ("long integer", long_integer_type_node);
 329   unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
 330   record_builtin_type ("unsigned int", unsigned_type_node);
 331   record_builtin_type (SIZE_TYPE, sizetype);
 332   record_builtin_type ("boolean", boolean_type_node);
 333   record_builtin_type ("void", void_type_node);
 334
 335   /* Save the type we made for integer as the type for Standard.Integer.  */
 336   save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node),
 337                  false);
 338
 339   /* Save the type we made for boolean as the type for Standard.Boolean.  */
 340   save_gnu_tree (Base_Type (standard_boolean), TYPE_NAME (boolean_type_node),
 341                  false);
 342   gnat_literal = First_Literal (Base_Type (standard_boolean));
 343   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 344   gcc_assert (t == boolean_false_node);
 345   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 346                        boolean_type_node, t, true, false, false, false,
 347                        NULL, gnat_literal);
 348   DECL_IGNORED_P (t) = 1;
 349   save_gnu_tree (gnat_literal, t, false);
 350   gnat_literal = Next_Literal (gnat_literal);
 351   t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
 352   gcc_assert (t == boolean_true_node);
 353   t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
 354                        boolean_type_node, t, true, false, false, false,
 355                        NULL, gnat_literal);
 356   DECL_IGNORED_P (t) = 1;
 357   save_gnu_tree (gnat_literal, t, false);
 358
 359   void_ftype = build_function_type (void_type_node, NULL_TREE);
 360   ptr_void_ftype = build_pointer_type (void_ftype);
 361
 362   /* Now declare runtime functions.  */
 363   t = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
 364
 365   /* malloc is a function declaration tree for a function to allocate
 366      memory.  */
 367   malloc_decl
 368     = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
 369                            build_function_type (ptr_void_type_node,
 370                                                 tree_cons (NULL_TREE,
 371                                                            sizetype, t)),
 372                            NULL_TREE, false, true, true, NULL, Empty);
 373   DECL_IS_MALLOC (malloc_decl) = 1;
 374
 375   /* malloc32 is a function declaration tree for a function to allocate
 376      32-bit memory on a 64-bit system.  Needed only on 64-bit VMS.  */
 377   malloc32_decl
 378     = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
 379                            build_function_type (ptr_void_type_node,
 380                                                 tree_cons (NULL_TREE,
 381                                                            sizetype, t)),
 382                            NULL_TREE, false, true, true, NULL, Empty);
 383   DECL_IS_MALLOC (malloc32_decl) = 1;
 384
 385   /* free is a function declaration tree for a function to free memory.  */
 386   free_decl
 387     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
 388                            build_function_type (void_type_node,
 389                                                 tree_cons (NULL_TREE,
 390                                                            ptr_void_type_node,
 391                                                            t)),
 392                            NULL_TREE, false, true, true, NULL, Empty);
 393
 394   /* This is used for 64-bit multiplication with overflow checking.  */
 395   mulv64_decl
 396     = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
 397                            build_function_type_list (int64_type, int64_type,
 398                                                      int64_type, NULL_TREE),
 399                            NULL_TREE, false, true, true, NULL, Empty);
 400
 401   /* Make the types and functions used for exception processing.  */
 402   jmpbuf_type
 403     = build_array_type (gnat_type_for_mode (Pmode, 0),
 404                         build_index_type (size_int (5)));
 405   record_builtin_type ("JMPBUF_T", jmpbuf_type);
 406   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
 407
 408   /* Functions to get and set the jumpbuf pointer for the current thread.  */
 409   get_jmpbuf_decl
 410     = create_subprog_decl
 411     (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
 412      NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
 413      NULL_TREE, false, true, true, NULL, Empty);
 414   /* Avoid creating superfluous edges to __builtin_setjmp receivers.  */
 415   DECL_PURE_P (get_jmpbuf_decl) = 1;
 416
 417   set_jmpbuf_decl
 418     = create_subprog_decl
 419     (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
 420      NULL_TREE,
 421      build_function_type (void_type_node,
 422                           tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
 423      NULL_TREE, false, true, true, NULL, Empty);
 424
 425   /* setjmp returns an integer and has one operand, which is a pointer to
 426      a jmpbuf.  */
 427   setjmp_decl
 428     = create_subprog_decl
 429       (get_identifier ("__builtin_setjmp"), NULL_TREE,
 430        build_function_type (integer_type_node,
 431                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, t)),
 432        NULL_TREE, false, true, true, NULL, Empty);
 433
 434   DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
 435   DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
 436
 437   /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
 438      address.  */
 439   update_setjmp_buf_decl
 440     = create_subprog_decl
 441       (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
 442        build_function_type (void_type_node,
 443                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, t)),
 444        NULL_TREE, false, true, true, NULL, Empty);
 445
 446   DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
 447   DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
 448
 449   /* Hooks to call when entering/leaving an exception handler.  */
 450   begin_handler_decl
 451     = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
 452                            build_function_type (void_type_node,
 453                                                 tree_cons (NULL_TREE,
 454                                                            ptr_void_type_node,
 455                                                            t)),
 456                            NULL_TREE, false, true, true, NULL, Empty);
 457
 458   end_handler_decl
 459     = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
 460                            build_function_type (void_type_node,
 461                                                 tree_cons (NULL_TREE,
 462                                                            ptr_void_type_node,
 463                                                            t)),
 464                            NULL_TREE, false, true, true, NULL, Empty);
 465
 466   /* If in no exception handlers mode, all raise statements are redirected to
 467      __gnat_last_chance_handler.  No need to redefine raise_nodefer_decl since
 468      this procedure will never be called in this mode.  */
 469   if (No_Exception_Handlers_Set ())
 470     {
 471       tree decl
 472         = create_subprog_decl
 473           (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
 474            build_function_type (void_type_node,
 475                                 tree_cons (NULL_TREE,
 476                                            build_pointer_type (char_type_node),
 477                                            tree_cons (NULL_TREE,
 478                                                       integer_type_node,
 479                                                       t))),
 480            NULL_TREE, false, true, true, NULL, Empty);
 481
 482       for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 483         gnat_raise_decls[i] = decl;
 484     }
 485   else
 486     /* Otherwise, make one decl for each exception reason.  */
 487     for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 488       {
 489         char name[17];
 490
 491         sprintf (name, "__gnat_rcheck_%.2d", i);
 492         gnat_raise_decls[i]
 493           = create_subprog_decl
 494             (get_identifier (name), NULL_TREE,
 495              build_function_type (void_type_node,
 496                                   tree_cons (NULL_TREE,
 497                                              build_pointer_type
 498                                              (char_type_node),
 499                                              tree_cons (NULL_TREE,
 500                                                         integer_type_node,
 501                                                         t))),
 502              NULL_TREE, false, true, true, NULL, Empty);
 503       }
 504
 505   for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
 506     {
 507       TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
 508       TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
 509       TREE_TYPE (gnat_raise_decls[i])
 510         = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
 511                                 TYPE_QUAL_VOLATILE);
 512     }
 513
 514   /* Set the types that GCC and Gigi use from the front end.  We would
 515      like to do this for char_type_node, but it needs to correspond to
 516      the C char type.  */
 517   exception_type
 518     = gnat_to_gnu_entity (Base_Type (standard_exception_type),  NULL_TREE, 0);
 519   except_type_node = TREE_TYPE (exception_type);
 520
 521   /* Make other functions used for exception processing.  */
 522   get_excptr_decl
 523     = create_subprog_decl
 524     (get_identifier ("system__soft_links__get_gnat_exception"),
 525      NULL_TREE,
 526      build_function_type (build_pointer_type (except_type_node), NULL_TREE),
 527      NULL_TREE, false, true, true, NULL, Empty);
 528   /* Avoid creating superfluous edges to __builtin_setjmp receivers.  */
 529   DECL_PURE_P (get_excptr_decl) = 1;
 530
 531   raise_nodefer_decl
 532     = create_subprog_decl
 533       (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
 534        build_function_type (void_type_node,
 535                             tree_cons (NULL_TREE,
 536                                        build_pointer_type (except_type_node),
 537                                        t)),
 538        NULL_TREE, false, true, true, NULL, Empty);
 539
 540   /* Indicate that these never return.  */
 541   TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
 542   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
 543   TREE_TYPE (raise_nodefer_decl)
 544     = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
 545                             TYPE_QUAL_VOLATILE);
 546
 547   /* Build the special descriptor type and its null node if needed.  */
 548   if (TARGET_VTABLE_USES_DESCRIPTORS)
 549     {
 550       tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
 551       tree field_list = NULL_TREE, null_list = NULL_TREE;
 552       int j;
 553
 554       fdesc_type_node = make_node (RECORD_TYPE);
 555
 556       for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
 557         {
 558           tree field = create_field_decl (NULL_TREE, ptr_void_ftype,
 559                                           fdesc_type_node, 0, 0, 0, 1);
 560           TREE_CHAIN (field) = field_list;
 561           field_list = field;
 562           null_list = tree_cons (field, null_node, null_list);
 563         }
 564
 565       finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
 566       record_builtin_type ("descriptor", fdesc_type_node);
 567       null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
 568     }
 569
 570   long_long_float_type
 571     = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
 572
 573   if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
 574     {
 575       /* In this case, the builtin floating point types are VAX float,
 576          so make up a type for use.  */
 577       longest_float_type_node = make_node (REAL_TYPE);
 578       TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
 579       layout_type (longest_float_type_node);
 580       record_builtin_type ("longest float type", longest_float_type_node);
 581     }
 582   else
 583     longest_float_type_node = TREE_TYPE (long_long_float_type);
 584
 585   /* Dummy objects to materialize "others" and "all others" in the exception
 586      tables.  These are exported by a-exexpr.adb, so see this unit for the
 587      types to use.  */
 588   others_decl
 589     = create_var_decl (get_identifier ("OTHERS"),
 590                        get_identifier ("__gnat_others_value"),
 591                        integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
 592
 593   all_others_decl
 594     = create_var_decl (get_identifier ("ALL_OTHERS"),
 595                        get_identifier ("__gnat_all_others_value"),
 596                        integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
 597
 598   main_identifier_node = get_identifier ("main");
 599
 600   /* Install the builtins we might need, either internally or as
 601      user available facilities for Intrinsic imports.  */
 602   gnat_install_builtins ();
 603
 604   gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 605   gnu_constraint_error_label_stack
 606     = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 607   gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 608   gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 609
 610   /* Process any Pragma Ident for the main unit.  */
 611 #ifdef ASM_OUTPUT_IDENT
 612   if (Present (Ident_String (Main_Unit)))
 613     ASM_OUTPUT_IDENT
 614       (asm_out_file,
 615        TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
 616 #endif
 617
 618   /* If we are using the GCC exception mechanism, let GCC know.  */
 619   if (Exception_Mechanism == Back_End_Exceptions)
 620     gnat_init_gcc_eh ();
 621
 622   /* Now translate the compilation unit proper.  */
 623   start_stmt_group ();
 624   Compilation_Unit_to_gnu (gnat_root);
 625
 626   /* Finally see if we have any elaboration procedures to deal with.  */
 627   for (info = elab_info_list; info; info = info->next)
 628     {
 629       tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
 630
 631       /* Unshare SAVE_EXPRs between subprograms.  These are not unshared by
 632          the gimplifier for obvious reasons, but it turns out that we need to
 633          unshare them for the global level because of SAVE_EXPRs made around
 634          checks for global objects and around allocators for global objects
 635          of variable size, in order to prevent node sharing in the underlying
 636          expression.  Note that this implicitly assumes that the SAVE_EXPR
 637          nodes themselves are not shared between subprograms, which would be
 638          an upstream bug for which we would not change the outcome.  */
 639       walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL);
 640
 641       /* We should have a BIND_EXPR but it may not have any statements in it.
 642          If it doesn't have any, we have nothing to do except for setting the
 643          flag on the GNAT node.  Otherwise, process the function as others.  */
 644       gnu_stmts = gnu_body;
 645       if (TREE_CODE (gnu_stmts) == BIND_EXPR)
 646         gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
 647       if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
 648         Set_Has_No_Elaboration_Code (info->gnat_node, 1);
 649       else
 650         {
 651           begin_subprog_body (info->elab_proc);
 652           end_subprog_body (gnu_body);
 653         }
 654     }
 655
 656   /* We cannot track the location of errors past this point.  */
 657   error_gnat_node = Empty;
 658 }
 659 \f
 660 /* Return a positive value if an lvalue is required for GNAT_NODE.  GNU_TYPE
 661    is the type that will be used for GNAT_NODE in the translated GNU tree.
 662    CONSTANT indicates whether the underlying object represented by GNAT_NODE
 663    is constant in the Ada sense, ALIASED whether it is aliased (but the latter
 664    doesn't affect the outcome if CONSTANT is not true).
 665
 666    The function climbs up the GNAT tree starting from the node and returns 1
 667    upon encountering a node that effectively requires an lvalue downstream.
 668    It returns int instead of bool to facilitate usage in non-purely binary
 669    logic contexts.  */
 670
 671 static int
 672 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
 673                    bool aliased)
 674 {
 675   Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
 676
 677   switch (Nkind (gnat_parent))
 678     {
 679     case N_Reference:
 680       return 1;
 681
 682     case N_Attribute_Reference:
 683       {
 684         unsigned char id = Get_Attribute_Id (Attribute_Name (gnat_parent));
 685         return id == Attr_Address
 686                || id == Attr_Access
 687                || id == Attr_Unchecked_Access
 688                || id == Attr_Unrestricted_Access
 689                || id == Attr_Bit_Position
 690                || id == Attr_Position
 691                || id == Attr_First_Bit
 692                || id == Attr_Last_Bit
 693                || id == Attr_Bit;
 694       }
 695
 696     case N_Parameter_Association:
 697     case N_Function_Call:
 698     case N_Procedure_Call_Statement:
 699       return (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type));
 700
 701     case N_Indexed_Component:
 702       /* Only the array expression can require an lvalue.  */
 703       if (Prefix (gnat_parent) != gnat_node)
 704         return 0;
 705
 706       /* ??? Consider that referencing an indexed component with a
 707          non-constant index forces the whole aggregate to memory.
 708          Note that N_Integer_Literal is conservative, any static
 709          expression in the RM sense could probably be accepted.  */
 710       for (gnat_temp = First (Expressions (gnat_parent));
 711            Present (gnat_temp);
 712            gnat_temp = Next (gnat_temp))
 713         if (Nkind (gnat_temp) != N_Integer_Literal)
 714           return 1;
 715
 716       /* ... fall through ... */
 717
 718     case N_Slice:
 719       /* Only the array expression can require an lvalue.  */
 720       if (Prefix (gnat_parent) != gnat_node)
 721         return 0;
 722
 723       aliased |= Has_Aliased_Components (Etype (gnat_node));
 724       return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
 725
 726     case N_Selected_Component:
 727       aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
 728       return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
 729
 730     case N_Object_Renaming_Declaration:
 731       /* We need to make a real renaming only if the constant object is
 732          aliased or if we may use a renaming pointer; otherwise we can
 733          optimize and return the rvalue.  We make an exception if the object
 734          is an identifier since in this case the rvalue can be propagated
 735          attached to the CONST_DECL.  */
 736       return (!constant
 737               || aliased
 738               /* This should match the constant case of the renaming code.  */
 739               || Is_Composite_Type
 740                  (Underlying_Type (Etype (Name (gnat_parent))))
 741               || Nkind (Name (gnat_parent)) == N_Identifier);
 742
 743     case N_Object_Declaration:
 744       /* We cannot use a constructor if this is an atomic object because
 745          the actual assignment might end up being done component-wise.  */
 746       return Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 747              && Is_Atomic (Defining_Entity (gnat_parent));
 748
 749     case N_Assignment_Statement:
 750       /* We cannot use a constructor if the LHS is an atomic object because
 751          the actual assignment might end up being done component-wise.  */
 752       return (Name (gnat_parent) == gnat_node
 753               || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 754                   && Is_Atomic (Entity (Name (gnat_parent)))));
 755
 756     case N_Unchecked_Type_Conversion:
 757       /* Returning 0 is very likely correct but we get better code if we
 758          go through the conversion.  */
 759       return lvalue_required_p (gnat_parent,
 760                                 get_unpadded_type (Etype (gnat_parent)),
 761                                 constant, aliased);
 762
 763     default:
 764       return 0;
 765     }
 766
 767   gcc_unreachable ();
 768 }
 769
 770 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
 771    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer
 772    to where we should place the result type.  */
 773
 774 static tree
 775 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 776 {
 777   Node_Id gnat_temp, gnat_temp_type;
 778   tree gnu_result, gnu_result_type;
 779
 780   /* Whether we should require an lvalue for GNAT_NODE.  Needed in
 781      specific circumstances only, so evaluated lazily.  < 0 means
 782      unknown, > 0 means known true, 0 means known false.  */
 783   int require_lvalue = -1;
 784
 785   /* If GNAT_NODE is a constant, whether we should use the initialization
 786      value instead of the constant entity, typically for scalars with an
 787      address clause when the parent doesn't require an lvalue.  */
 788   bool use_constant_initializer = false;
 789
 790   /* If the Etype of this node does not equal the Etype of the Entity,
 791      something is wrong with the entity map, probably in generic
 792      instantiation. However, this does not apply to types. Since we sometime
 793      have strange Ekind's, just do this test for objects. Also, if the Etype of
 794      the Entity is private, the Etype of the N_Identifier is allowed to be the
 795      full type and also we consider a packed array type to be the same as the
 796      original type. Similarly, a class-wide type is equivalent to a subtype of
 797      itself. Finally, if the types are Itypes, one may be a copy of the other,
 798      which is also legal.  */
 799   gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
 800                ? gnat_node : Entity (gnat_node));
 801   gnat_temp_type = Etype (gnat_temp);
 802
 803   gcc_assert (Etype (gnat_node) == gnat_temp_type
 804               || (Is_Packed (gnat_temp_type)
 805                   && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
 806               || (Is_Class_Wide_Type (Etype (gnat_node)))
 807               || (IN (Ekind (gnat_temp_type), Private_Kind)
 808                   && Present (Full_View (gnat_temp_type))
 809                   && ((Etype (gnat_node) == Full_View (gnat_temp_type))
 810                       || (Is_Packed (Full_View (gnat_temp_type))
 811                           && (Etype (gnat_node)
 812                               == Packed_Array_Type (Full_View
 813                                                     (gnat_temp_type))))))
 814               || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
 815               || !(Ekind (gnat_temp) == E_Variable
 816                    || Ekind (gnat_temp) == E_Component
 817                    || Ekind (gnat_temp) == E_Constant
 818                    || Ekind (gnat_temp) == E_Loop_Parameter
 819                    || IN (Ekind (gnat_temp), Formal_Kind)));
 820
 821   /* If this is a reference to a deferred constant whose partial view is an
 822      unconstrained private type, the proper type is on the full view of the
 823      constant, not on the full view of the type, which may be unconstrained.
 824
 825      This may be a reference to a type, for example in the prefix of the
 826      attribute Position, generated for dispatching code (see Make_DT in
 827      exp_disp,adb). In that case we need the type itself, not is parent,
 828      in particular if it is a derived type  */
 829   if (Is_Private_Type (gnat_temp_type)
 830       && Has_Unknown_Discriminants (gnat_temp_type)
 831       && Ekind (gnat_temp) == E_Constant
 832       && Present (Full_View (gnat_temp)))
 833     {
 834       gnat_temp = Full_View (gnat_temp);
 835       gnat_temp_type = Etype (gnat_temp);
 836     }
 837   else
 838     {
 839       /* We want to use the Actual_Subtype if it has already been elaborated,
 840          otherwise the Etype.  Avoid using Actual_Subtype for packed arrays to
 841          simplify things.  */
 842       if ((Ekind (gnat_temp) == E_Constant
 843            || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
 844           && !(Is_Array_Type (Etype (gnat_temp))
 845                && Present (Packed_Array_Type (Etype (gnat_temp))))
 846           && Present (Actual_Subtype (gnat_temp))
 847           && present_gnu_tree (Actual_Subtype (gnat_temp)))
 848         gnat_temp_type = Actual_Subtype (gnat_temp);
 849       else
 850         gnat_temp_type = Etype (gnat_node);
 851     }
 852
 853   /* Expand the type of this identifier first, in case it is an enumeral
 854      literal, which only get made when the type is expanded.  There is no
 855      order-of-elaboration issue here.  */
 856   gnu_result_type = get_unpadded_type (gnat_temp_type);
 857
 858   /* If this is a non-imported scalar constant with an address clause,
 859      retrieve the value instead of a pointer to be dereferenced unless
 860      an lvalue is required.  This is generally more efficient and actually
 861      required if this is a static expression because it might be used
 862      in a context where a dereference is inappropriate, such as a case
 863      statement alternative or a record discriminant.  There is no possible
 864      volatile-ness short-circuit here since Volatile constants must bei
 865      imported per C.6.  */
 866   if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type)
 867       && !Is_Imported (gnat_temp)
 868       && Present (Address_Clause (gnat_temp)))
 869     {
 870       require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
 871                                           Is_Aliased (gnat_temp));
 872       use_constant_initializer = !require_lvalue;
 873     }
 874
 875   if (use_constant_initializer)
 876     {
 877       /* If this is a deferred constant, the initializer is attached to
 878          the full view.  */
 879       if (Present (Full_View (gnat_temp)))
 880         gnat_temp = Full_View (gnat_temp);
 881
 882       gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
 883     }
 884   else
 885     gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
 886
 887   /* If we are in an exception handler, force this variable into memory to
 888      ensure optimization does not remove stores that appear redundant but are
 889      actually needed in case an exception occurs.
 890
 891      ??? Note that we need not do this if the variable is declared within the
 892      handler, only if it is referenced in the handler and declared in an
 893      enclosing block, but we have no way of testing that right now.
 894
 895      ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
 896      here, but it can now be removed by the Tree aliasing machinery if the
 897      address of the variable is never taken.  All we can do is to make the
 898      variable volatile, which might incur the generation of temporaries just
 899      to access the memory in some circumstances.  This can be avoided for
 900      variables of non-constant size because they are automatically allocated
 901      to memory.  There might be no way of allocating a proper temporary for
 902      them in any case.  We only do this for SJLJ though.  */
 903   if (TREE_VALUE (gnu_except_ptr_stack)
 904       && TREE_CODE (gnu_result) == VAR_DECL
 905       && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST)
 906     TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
 907
 908   /* Some objects (such as parameters passed by reference, globals of
 909      variable size, and renamed objects) actually represent the address
 910      of the object.  In that case, we must do the dereference.  Likewise,
 911      deal with parameters to foreign convention subprograms.  */
 912   if (DECL_P (gnu_result)
 913       && (DECL_BY_REF_P (gnu_result)
 914           || (TREE_CODE (gnu_result) == PARM_DECL
 915               && DECL_BY_COMPONENT_PTR_P (gnu_result))))
 916     {
 917       bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
 918       tree renamed_obj;
 919
 920       if (TREE_CODE (gnu_result) == PARM_DECL
 921           && DECL_BY_COMPONENT_PTR_P (gnu_result))
 922         gnu_result
 923           = build_unary_op (INDIRECT_REF, NULL_TREE,
 924                             convert (build_pointer_type (gnu_result_type),
 925                                      gnu_result));
 926
 927       /* If it's a renaming pointer and we are at the right binding level,
 928          we can reference the renamed object directly, since the renamed
 929          expression has been protected against multiple evaluations.  */
 930       else if (TREE_CODE (gnu_result) == VAR_DECL
 931                && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0
 932                && (! DECL_RENAMING_GLOBAL_P (gnu_result)
 933                    || global_bindings_p ()))
 934         gnu_result = renamed_obj;
 935
 936       /* Return the underlying CST for a CONST_DECL like a few lines below,
 937          after dereferencing in this case.  */
 938       else if (TREE_CODE (gnu_result) == CONST_DECL)
 939         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
 940                                      DECL_INITIAL (gnu_result));
 941
 942       else
 943         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
 944
 945       TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
 946     }
 947
 948   /* The GNAT tree has the type of a function as the type of its result.  Also
 949      use the type of the result if the Etype is a subtype which is nominally
 950      unconstrained.  But remove any padding from the resulting type.  */
 951   if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
 952       || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
 953     {
 954       gnu_result_type = TREE_TYPE (gnu_result);
 955       if (TYPE_IS_PADDING_P (gnu_result_type))
 956         gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
 957     }
 958
 959   /* If we have a constant declaration and its initializer at hand,
 960      try to return the latter to avoid the need to call fold in lots
 961      of places and the need of elaboration code if this Id is used as
 962      an initializer itself.  */
 963   if (TREE_CONSTANT (gnu_result)
 964       && DECL_P (gnu_result)
 965       && DECL_INITIAL (gnu_result))
 966     {
 967       tree object
 968         = (TREE_CODE (gnu_result) == CONST_DECL
 969            ? DECL_CONST_CORRESPONDING_VAR (gnu_result) : gnu_result);
 970
 971       /* If there is a corresponding variable, we only want to return
 972          the CST value if an lvalue is not required.  Evaluate this
 973          now if we have not already done so.  */
 974       if (object && require_lvalue < 0)
 975         require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
 976                                             Is_Aliased (gnat_temp));
 977
 978       if (!object || !require_lvalue)
 979         gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
 980     }
 981
 982   *gnu_result_type_p = gnu_result_type;
 983   return gnu_result;
 984 }
 985 \f
 986 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
 987    any statements we generate.  */
 988
 989 static tree
 990 Pragma_to_gnu (Node_Id gnat_node)
 991 {
 992   Node_Id gnat_temp;
 993   tree gnu_result = alloc_stmt_list ();
 994
 995   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
 996      annotating types.  */
 997   if (type_annotate_only
 998       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
 999     return gnu_result;
1000
1001   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1002     {
1003     case Pragma_Inspection_Point:
1004       /* Do nothing at top level: all such variables are already viewable.  */
1005       if (global_bindings_p ())
1006         break;
1007
1008       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1009            Present (gnat_temp);
1010            gnat_temp = Next (gnat_temp))
1011         {
1012           Node_Id gnat_expr = Expression (gnat_temp);
1013           tree gnu_expr = gnat_to_gnu (gnat_expr);
1014           int use_address;
1015           enum machine_mode mode;
1016           tree asm_constraint = NULL_TREE;
1017 #ifdef ASM_COMMENT_START
1018           char *comment;
1019 #endif
1020
1021           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1022             gnu_expr = TREE_OPERAND (gnu_expr, 0);
1023
1024           /* Use the value only if it fits into a normal register,
1025              otherwise use the address.  */
1026           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1027           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1028                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1029                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1030
1031           if (use_address)
1032             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1033
1034 #ifdef ASM_COMMENT_START
1035           comment = concat (ASM_COMMENT_START,
1036                             " inspection point: ",
1037                             Get_Name_String (Chars (gnat_expr)),
1038                             use_address ? " address" : "",
1039                             " is in %0",
1040                             NULL);
1041           asm_constraint = build_string (strlen (comment), comment);
1042           free (comment);
1043 #endif
1044           gnu_expr = build5 (ASM_EXPR, void_type_node,
1045                              asm_constraint,
1046                              NULL_TREE,
1047                              tree_cons
1048                              (build_tree_list (NULL_TREE,
1049                                                build_string (1, "g")),
1050                               gnu_expr, NULL_TREE),
1051                              NULL_TREE, NULL_TREE);
1052           ASM_VOLATILE_P (gnu_expr) = 1;
1053           set_expr_location_from_node (gnu_expr, gnat_node);
1054           append_to_statement_list (gnu_expr, &gnu_result);
1055         }
1056       break;
1057
1058     case Pragma_Optimize:
1059       switch (Chars (Expression
1060                      (First (Pragma_Argument_Associations (gnat_node)))))
1061         {
1062         case Name_Time:  case Name_Space:
1063           if (!optimize)
1064             post_error ("insufficient -O value?", gnat_node);
1065           break;
1066
1067         case Name_Off:
1068           if (optimize)
1069             post_error ("must specify -O0?", gnat_node);
1070           break;
1071
1072         default:
1073           gcc_unreachable ();
1074         }
1075       break;
1076
1077     case Pragma_Reviewable:
1078       if (write_symbols == NO_DEBUG)
1079         post_error ("must specify -g?", gnat_node);
1080       break;
1081     }
1082
1083   return gnu_result;
1084 }
1085 \f
1086 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1087    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
1088    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
1089
1090 static tree
1091 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1092 {
1093   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1094   tree gnu_type = TREE_TYPE (gnu_prefix);
1095   tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1096   bool prefix_unused = false;
1097
1098   /* If the input is a NULL_EXPR, make a new one.  */
1099   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1100     {
1101       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1102       *gnu_result_type_p = gnu_result_type;
1103       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1104     }
1105
1106   switch (attribute)
1107     {
1108     case Attr_Pos:
1109     case Attr_Val:
1110       /* These are just conversions since representation clauses for
1111          enumeration types are handled in the front-end.  */
1112       {
1113         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1114         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1115         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1116         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1117                                          checkp, checkp, true, gnat_node);
1118       }
1119       break;
1120
1121     case Attr_Pred:
1122     case Attr_Succ:
1123       /* These just add or subtract the constant 1 since representation
1124          clauses for enumeration types are handled in the front-end.  */
1125       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1126       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1127
1128       if (Do_Range_Check (First (Expressions (gnat_node))))
1129         {
1130           gnu_expr = protect_multiple_eval (gnu_expr);
1131           gnu_expr
1132             = emit_check
1133               (build_binary_op (EQ_EXPR, integer_type_node,
1134                                 gnu_expr,
1135                                 attribute == Attr_Pred
1136                                 ? TYPE_MIN_VALUE (gnu_result_type)
1137                                 : TYPE_MAX_VALUE (gnu_result_type)),
1138                gnu_expr, CE_Range_Check_Failed, gnat_node);
1139         }
1140
1141       gnu_result
1142         = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1143                            gnu_result_type, gnu_expr,
1144                            convert (gnu_result_type, integer_one_node));
1145       break;
1146
1147     case Attr_Address:
1148     case Attr_Unrestricted_Access:
1149       /* Conversions don't change addresses but can cause us to miss the
1150          COMPONENT_REF case below, so strip them off.  */
1151       gnu_prefix = remove_conversions (gnu_prefix,
1152                                        !Must_Be_Byte_Aligned (gnat_node));
1153
1154       /* If we are taking 'Address of an unconstrained object, this is the
1155          pointer to the underlying array.  */
1156       if (attribute == Attr_Address)
1157         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1158
1159       /* If we are building a static dispatch table, we have to honor
1160          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1161          with the C++ ABI.  We do it in the non-static case as well,
1162          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
1163       else if (TARGET_VTABLE_USES_DESCRIPTORS
1164                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1165         {
1166           tree gnu_field, gnu_list = NULL_TREE, t;
1167           /* Descriptors can only be built here for top-level functions.  */
1168           bool build_descriptor = (global_bindings_p () != 0);
1169           int i;
1170
1171           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1172
1173           /* If we're not going to build the descriptor, we have to retrieve
1174              the one which will be built by the linker (or by the compiler
1175              later if a static chain is requested).  */
1176           if (!build_descriptor)
1177             {
1178               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1179               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1180                                          gnu_result);
1181               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1182             }
1183
1184           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1185                i < TARGET_VTABLE_USES_DESCRIPTORS;
1186                gnu_field = TREE_CHAIN (gnu_field), i++)
1187             {
1188               if (build_descriptor)
1189                 {
1190                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1191                               build_int_cst (NULL_TREE, i));
1192                   TREE_CONSTANT (t) = 1;
1193                 }
1194               else
1195                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1196                             gnu_field, NULL_TREE);
1197
1198               gnu_list = tree_cons (gnu_field, t, gnu_list);
1199             }
1200
1201           gnu_result = gnat_build_constructor (gnu_result_type, gnu_list);
1202           break;
1203         }
1204
1205       /* ... fall through ... */
1206
1207     case Attr_Access:
1208     case Attr_Unchecked_Access:
1209     case Attr_Code_Address:
1210       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1211       gnu_result
1212         = build_unary_op (((attribute == Attr_Address
1213                             || attribute == Attr_Unrestricted_Access)
1214                            && !Must_Be_Byte_Aligned (gnat_node))
1215                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
1216                           gnu_result_type, gnu_prefix);
1217
1218       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1219          don't try to build a trampoline.  */
1220       if (attribute == Attr_Code_Address)
1221         {
1222           for (gnu_expr = gnu_result;
1223                CONVERT_EXPR_P (gnu_expr);
1224                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1225             TREE_CONSTANT (gnu_expr) = 1;
1226
1227           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1228             TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1229         }
1230
1231       /* For other address attributes applied to a nested function,
1232          find an inner ADDR_EXPR and annotate it so that we can issue
1233          a useful warning with -Wtrampolines.  */
1234       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1235         {
1236           for (gnu_expr = gnu_result;
1237                CONVERT_EXPR_P (gnu_expr);
1238                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1239             ;
1240
1241           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1242               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1243             {
1244               set_expr_location_from_node (gnu_expr, gnat_node);
1245
1246               /* Check that we're not violating the No_Implicit_Dynamic_Code
1247                  restriction.  Be conservative if we don't know anything
1248                  about the trampoline strategy for the target.  */
1249               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1250             }
1251         }
1252       break;
1253
1254     case Attr_Pool_Address:
1255       {
1256         tree gnu_obj_type;
1257         tree gnu_ptr = gnu_prefix;
1258
1259         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1260
1261         /* If this is an unconstrained array, we know the object has been
1262            allocated with the template in front of the object.  So compute
1263            the template address.  */
1264         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1265           gnu_ptr
1266             = convert (build_pointer_type
1267                        (TYPE_OBJECT_RECORD_TYPE
1268                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1269                        gnu_ptr);
1270
1271         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1272         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1273             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1274           {
1275             tree gnu_char_ptr_type = build_pointer_type (char_type_node);
1276             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1277             tree gnu_byte_offset
1278               = convert (sizetype,
1279                          size_diffop (size_zero_node, gnu_pos));
1280             gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
1281
1282             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1283             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1284                                        gnu_ptr, gnu_byte_offset);
1285           }
1286
1287         gnu_result = convert (gnu_result_type, gnu_ptr);
1288       }
1289       break;
1290
1291     case Attr_Size:
1292     case Attr_Object_Size:
1293     case Attr_Value_Size:
1294     case Attr_Max_Size_In_Storage_Elements:
1295       gnu_expr = gnu_prefix;
1296
1297       /* Remove NOPs and conversions between original and packable version
1298          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1299          to see if a COMPONENT_REF was involved.  */
1300       while (TREE_CODE (gnu_expr) == NOP_EXPR
1301              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1302                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1303                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1304                     == RECORD_TYPE
1305                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1306                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1307         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1308
1309       gnu_prefix = remove_conversions (gnu_prefix, true);
1310       prefix_unused = true;
1311       gnu_type = TREE_TYPE (gnu_prefix);
1312
1313       /* Replace an unconstrained array type with the type of the underlying
1314          array.  We can't do this with a call to maybe_unconstrained_array
1315          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1316          use the record type that will be used to allocate the object and its
1317          template.  */
1318       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1319         {
1320           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1321           if (attribute != Attr_Max_Size_In_Storage_Elements)
1322             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1323         }
1324
1325       /* If we're looking for the size of a field, return the field size.
1326          Otherwise, if the prefix is an object, or if we're looking for
1327          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1328          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1329       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1330         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1331       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1332                || attribute == Attr_Object_Size
1333                || attribute == Attr_Max_Size_In_Storage_Elements)
1334         {
1335           /* If the prefix is an object of a padded type, the GCC size isn't
1336              relevant to the programmer.  Normally what we want is the RM size,
1337              which was set from the specified size, but if it was not set, we
1338              want the size of the field.  Using the MAX of those two produces
1339              the right result in all cases.  Don't use the size of the field
1340              if it's self-referential, since that's never what's wanted.  */
1341           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1342               && TYPE_IS_PADDING_P (gnu_type)
1343               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1344             {
1345               gnu_result = rm_size (gnu_type);
1346               if (!CONTAINS_PLACEHOLDER_P
1347                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1348                 gnu_result
1349                   = size_binop (MAX_EXPR, gnu_result,
1350                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1351             }
1352           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1353             {
1354               Node_Id gnat_deref = Prefix (gnat_node);
1355               Node_Id gnat_actual_subtype
1356                 = Actual_Designated_Subtype (gnat_deref);
1357               tree gnu_ptr_type
1358                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1359
1360               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1361                   && Present (gnat_actual_subtype))
1362                 {
1363                   tree gnu_actual_obj_type
1364                     = gnat_to_gnu_type (gnat_actual_subtype);
1365                   gnu_type
1366                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1367                                                       gnu_actual_obj_type,
1368                                                       get_identifier ("SIZE"));
1369                 }
1370
1371               gnu_result = TYPE_SIZE (gnu_type);
1372             }
1373           else
1374             gnu_result = TYPE_SIZE (gnu_type);
1375         }
1376       else
1377         gnu_result = rm_size (gnu_type);
1378
1379       gcc_assert (gnu_result);
1380
1381       /* Deal with a self-referential size by returning the maximum size for
1382          a type and by qualifying the size with the object for 'Size of an
1383          object.  */
1384       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1385         {
1386           if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1387             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1388           else
1389             gnu_result = max_size (gnu_result, true);
1390         }
1391
1392       /* If the type contains a template, subtract its size.  */
1393       if (TREE_CODE (gnu_type) == RECORD_TYPE
1394           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1395         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1396                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1397
1398       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1399
1400       if (attribute == Attr_Max_Size_In_Storage_Elements)
1401         gnu_result = fold_build2 (CEIL_DIV_EXPR, bitsizetype,
1402                                   gnu_result, bitsize_unit_node);
1403       break;
1404
1405     case Attr_Alignment:
1406       {
1407         unsigned int align;
1408
1409         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1410             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1411           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1412
1413         gnu_type = TREE_TYPE (gnu_prefix);
1414         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1415         prefix_unused = true;
1416
1417         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1418           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1419         else
1420           {
1421             Node_Id gnat_prefix = Prefix (gnat_node);
1422             Entity_Id gnat_type = Etype (gnat_prefix);
1423             unsigned int double_align;
1424             bool is_capped_double, align_clause;
1425
1426             /* If the default alignment of "double" or larger scalar types is
1427                specifically capped and there is an alignment clause neither
1428                on the type nor on the prefix itself, return the cap.  */
1429             if ((double_align = double_float_alignment) > 0)
1430               is_capped_double
1431                 = is_double_float_or_array (gnat_type, &align_clause);
1432             else if ((double_align = double_scalar_alignment) > 0)
1433               is_capped_double
1434                 = is_double_scalar_or_array (gnat_type, &align_clause);
1435             else
1436               is_capped_double = align_clause = false;
1437
1438             if (is_capped_double
1439                 && Nkind (gnat_prefix) == N_Identifier
1440                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1441               align_clause = true;
1442
1443             if (is_capped_double && !align_clause)
1444               align = double_align;
1445             else
1446               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1447           }
1448
1449         gnu_result = size_int (align);
1450       }
1451       break;
1452
1453     case Attr_First:
1454     case Attr_Last:
1455     case Attr_Range_Length:
1456       prefix_unused = true;
1457
1458       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1459         {
1460           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1461
1462           if (attribute == Attr_First)
1463             gnu_result = TYPE_MIN_VALUE (gnu_type);
1464           else if (attribute == Attr_Last)
1465             gnu_result = TYPE_MAX_VALUE (gnu_type);
1466           else
1467             gnu_result
1468               = build_binary_op
1469                 (MAX_EXPR, get_base_type (gnu_result_type),
1470                  build_binary_op
1471                  (PLUS_EXPR, get_base_type (gnu_result_type),
1472                   build_binary_op (MINUS_EXPR,
1473                                    get_base_type (gnu_result_type),
1474                                    convert (gnu_result_type,
1475                                             TYPE_MAX_VALUE (gnu_type)),
1476                                    convert (gnu_result_type,
1477                                             TYPE_MIN_VALUE (gnu_type))),
1478                   convert (gnu_result_type, integer_one_node)),
1479                  convert (gnu_result_type, integer_zero_node));
1480
1481           break;
1482         }
1483
1484       /* ... fall through ... */
1485
1486     case Attr_Length:
1487       {
1488         int Dimension = (Present (Expressions (gnat_node))
1489                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1490                          : 1), i;
1491         struct parm_attr_d *pa = NULL;
1492         Entity_Id gnat_param = Empty;
1493
1494         /* Make sure any implicit dereference gets done.  */
1495         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1496         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1497         /* We treat unconstrained array In parameters specially.  */
1498         if (Nkind (Prefix (gnat_node)) == N_Identifier
1499             && !Is_Constrained (Etype (Prefix (gnat_node)))
1500             && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1501           gnat_param = Entity (Prefix (gnat_node));
1502         gnu_type = TREE_TYPE (gnu_prefix);
1503         prefix_unused = true;
1504         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1505
1506         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1507           {
1508             int ndim;
1509             tree gnu_type_temp;
1510
1511             for (ndim = 1, gnu_type_temp = gnu_type;
1512                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1513                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1514                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1515               ;
1516
1517             Dimension = ndim + 1 - Dimension;
1518           }
1519
1520         for (i = 1; i < Dimension; i++)
1521           gnu_type = TREE_TYPE (gnu_type);
1522
1523         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1524
1525         /* When not optimizing, look up the slot associated with the parameter
1526            and the dimension in the cache and create a new one on failure.  */
1527         if (!optimize && Present (gnat_param))
1528           {
1529             for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
1530               if (pa->id == gnat_param && pa->dim == Dimension)
1531                 break;
1532
1533             if (!pa)
1534               {
1535                 pa = GGC_CNEW (struct parm_attr_d);
1536                 pa->id = gnat_param;
1537                 pa->dim = Dimension;
1538                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1539               }
1540           }
1541
1542         /* Return the cached expression or build a new one.  */
1543         if (attribute == Attr_First)
1544           {
1545             if (pa && pa->first)
1546               {
1547                 gnu_result = pa->first;
1548                 break;
1549               }
1550
1551             gnu_result
1552               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1553           }
1554
1555         else if (attribute == Attr_Last)
1556           {
1557             if (pa && pa->last)
1558               {
1559                 gnu_result = pa->last;
1560                 break;
1561               }
1562
1563             gnu_result
1564               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1565           }
1566
1567         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1568           {
1569             if (pa && pa->length)
1570               {
1571                 gnu_result = pa->length;
1572                 break;
1573               }
1574             else
1575               {
1576                 /* We used to compute the length as max (hb - lb + 1, 0),
1577                    which could overflow for some cases of empty arrays, e.g.
1578                    when lb == index_type'first.  We now compute the length as
1579                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1580                    much rarer cases, for extremely large arrays we expect
1581                    never to encounter in practice.  In addition, the former
1582                    computation required the use of potentially constraining
1583                    signed arithmetic while the latter doesn't.  Note that
1584                    the comparison must be done in the original index type,
1585                    to avoid any overflow during the conversion.  */
1586                 tree comp_type = get_base_type (gnu_result_type);
1587                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1588                 tree lb = TYPE_MIN_VALUE (index_type);
1589                 tree hb = TYPE_MAX_VALUE (index_type);
1590                 gnu_result
1591                   = build_binary_op (PLUS_EXPR, comp_type,
1592                                      build_binary_op (MINUS_EXPR,
1593                                                       comp_type,
1594                                                       convert (comp_type, hb),
1595                                                       convert (comp_type, lb)),
1596                                      convert (comp_type, integer_one_node));
1597                 gnu_result
1598                   = build_cond_expr (comp_type,
1599                                      build_binary_op (GE_EXPR,
1600                                                       integer_type_node,
1601                                                       hb, lb),
1602                                      gnu_result,
1603                                      convert (comp_type, integer_zero_node));
1604               }
1605           }
1606
1607         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1608            handling.  Note that these attributes could not have been used on
1609            an unconstrained array type.  */
1610         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1611
1612         /* Cache the expression we have just computed.  Since we want to do it
1613            at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1614            create the temporary.  */
1615         if (pa)
1616           {
1617             gnu_result
1618               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1619             TREE_SIDE_EFFECTS (gnu_result) = 1;
1620             if (attribute == Attr_First)
1621               pa->first = gnu_result;
1622             else if (attribute == Attr_Last)
1623               pa->last = gnu_result;
1624             else
1625               pa->length = gnu_result;
1626           }
1627
1628         /* Set the source location onto the predicate of the condition in the
1629            'Length case but do not do it if the expression is cached to avoid
1630            messing up the debug info.  */
1631         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1632                  && TREE_CODE (gnu_result) == COND_EXPR
1633                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1634           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1635                                        gnat_node);
1636
1637         break;
1638       }
1639
1640     case Attr_Bit_Position:
1641     case Attr_Position:
1642     case Attr_First_Bit:
1643     case Attr_Last_Bit:
1644     case Attr_Bit:
1645       {
1646         HOST_WIDE_INT bitsize;
1647         HOST_WIDE_INT bitpos;
1648         tree gnu_offset;
1649         tree gnu_field_bitpos;
1650         tree gnu_field_offset;
1651         tree gnu_inner;
1652         enum machine_mode mode;
1653         int unsignedp, volatilep;
1654
1655         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1656         gnu_prefix = remove_conversions (gnu_prefix, true);
1657         prefix_unused = true;
1658
1659         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1660            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1661         if (attribute == Attr_Bit
1662             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1663             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1664           {
1665             gnu_result = integer_zero_node;
1666             break;
1667           }
1668
1669         else
1670           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1671                       || (attribute == Attr_Bit_Position
1672                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1673
1674         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1675                              &mode, &unsignedp, &volatilep, false);
1676
1677         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1678           {
1679             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1680             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1681
1682             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1683                  TREE_CODE (gnu_inner) == COMPONENT_REF
1684                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1685                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1686               {
1687                 gnu_field_bitpos
1688                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1689                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1690                 gnu_field_offset
1691                   = size_binop (PLUS_EXPR, gnu_field_offset,
1692                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1693               }
1694           }
1695         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1696           {
1697             gnu_field_bitpos = bit_position (gnu_prefix);
1698             gnu_field_offset = byte_position (gnu_prefix);
1699           }
1700         else
1701           {
1702             gnu_field_bitpos = bitsize_zero_node;
1703             gnu_field_offset = size_zero_node;
1704           }
1705
1706         switch (attribute)
1707           {
1708           case Attr_Position:
1709             gnu_result = gnu_field_offset;
1710             break;
1711
1712           case Attr_First_Bit:
1713           case Attr_Bit:
1714             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1715             break;
1716
1717           case Attr_Last_Bit:
1718             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1719             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1720                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1721             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1722                                      bitsize_one_node);
1723             break;
1724
1725           case Attr_Bit_Position:
1726             gnu_result = gnu_field_bitpos;
1727             break;
1728                 }
1729
1730         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1731            handling.  */
1732         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1733         break;
1734       }
1735
1736     case Attr_Min:
1737     case Attr_Max:
1738       {
1739         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1740         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1741
1742         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1743         gnu_result = build_binary_op (attribute == Attr_Min
1744                                       ? MIN_EXPR : MAX_EXPR,
1745                                       gnu_result_type, gnu_lhs, gnu_rhs);
1746       }
1747       break;
1748
1749     case Attr_Passed_By_Reference:
1750       gnu_result = size_int (default_pass_by_ref (gnu_type)
1751                              || must_pass_by_ref (gnu_type));
1752       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1753       break;
1754
1755     case Attr_Component_Size:
1756       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1757           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1758         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1759
1760       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1761       gnu_type = TREE_TYPE (gnu_prefix);
1762
1763       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1764         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1765
1766       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1767              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1768         gnu_type = TREE_TYPE (gnu_type);
1769
1770       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1771
1772       /* Note this size cannot be self-referential.  */
1773       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1774       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1775       prefix_unused = true;
1776       break;
1777
1778     case Attr_Null_Parameter:
1779       /* This is just a zero cast to the pointer type for our prefix and
1780          dereferenced.  */
1781       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1782       gnu_result
1783         = build_unary_op (INDIRECT_REF, NULL_TREE,
1784                           convert (build_pointer_type (gnu_result_type),
1785                                    integer_zero_node));
1786       TREE_PRIVATE (gnu_result) = 1;
1787       break;
1788
1789     case Attr_Mechanism_Code:
1790       {
1791         int code;
1792         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1793
1794         prefix_unused = true;
1795         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1796         if (Present (Expressions (gnat_node)))
1797           {
1798             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1799
1800             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1801                  i--, gnat_obj = Next_Formal (gnat_obj))
1802               ;
1803           }
1804
1805         code = Mechanism (gnat_obj);
1806         if (code == Default)
1807           code = ((present_gnu_tree (gnat_obj)
1808                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1809                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1810                             == PARM_DECL)
1811                            && (DECL_BY_COMPONENT_PTR_P
1812                                (get_gnu_tree (gnat_obj))))))
1813                   ? By_Reference : By_Copy);
1814         gnu_result = convert (gnu_result_type, size_int (- code));
1815       }
1816       break;
1817
1818     default:
1819       /* Say we have an unimplemented attribute.  Then set the value to be
1820          returned to be a zero and hope that's something we can convert to
1821          the type of this attribute.  */
1822       post_error ("unimplemented attribute", gnat_node);
1823       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1824       gnu_result = integer_zero_node;
1825       break;
1826     }
1827
1828   /* If this is an attribute where the prefix was unused, force a use of it if
1829      it has a side-effect.  But don't do it if the prefix is just an entity
1830      name.  However, if an access check is needed, we must do it.  See second
1831      example in AARM 11.6(5.e).  */
1832   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1833       && !Is_Entity_Name (Prefix (gnat_node)))
1834     gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1835                               gnu_prefix, gnu_result);
1836
1837   *gnu_result_type_p = gnu_result_type;
1838   return gnu_result;
1839 }
1840 \f
1841 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1842    to a GCC tree, which is returned.  */
1843
1844 static tree
1845 Case_Statement_to_gnu (Node_Id gnat_node)
1846 {
1847   tree gnu_result;
1848   tree gnu_expr;
1849   Node_Id gnat_when;
1850
1851   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1852   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1853
1854   /*  The range of values in a case statement is determined by the rules in
1855       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1856       of the expression. One exception arises in the case of a simple name that
1857       is parenthesized. This still has the Etype of the name, but since it is
1858       not a name, para 7 does not apply, and we need to go to the base type.
1859       This is the only case where parenthesization affects the dynamic
1860       semantics (i.e. the range of possible values at runtime that is covered
1861       by the others alternative.
1862
1863       Another exception is if the subtype of the expression is non-static.  In
1864       that case, we also have to use the base type.  */
1865   if (Paren_Count (Expression (gnat_node)) != 0
1866       || !Is_OK_Static_Subtype (Underlying_Type
1867                                 (Etype (Expression (gnat_node)))))
1868     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1869
1870   /* We build a SWITCH_EXPR that contains the code with interspersed
1871      CASE_LABEL_EXPRs for each label.  */
1872
1873   push_stack (&gnu_switch_label_stack, NULL_TREE,
1874               create_artificial_label (input_location));
1875   start_stmt_group ();
1876   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1877        Present (gnat_when);
1878        gnat_when = Next_Non_Pragma (gnat_when))
1879     {
1880       Node_Id gnat_choice;
1881       int choices_added = 0;
1882
1883       /* First compile all the different case choices for the current WHEN
1884          alternative.  */
1885       for (gnat_choice = First (Discrete_Choices (gnat_when));
1886            Present (gnat_choice); gnat_choice = Next (gnat_choice))
1887         {
1888           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1889
1890           switch (Nkind (gnat_choice))
1891             {
1892             case N_Range:
1893               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1894               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1895               break;
1896
1897             case N_Subtype_Indication:
1898               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1899                                                 (Constraint (gnat_choice))));
1900               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1901                                                   (Constraint (gnat_choice))));
1902               break;
1903
1904             case N_Identifier:
1905             case N_Expanded_Name:
1906               /* This represents either a subtype range or a static value of
1907                  some kind; Ekind says which.  */
1908               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1909                 {
1910                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1911
1912                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1913                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1914                   break;
1915                 }
1916
1917               /* ... fall through ... */
1918
1919             case N_Character_Literal:
1920             case N_Integer_Literal:
1921               gnu_low = gnat_to_gnu (gnat_choice);
1922               break;
1923
1924             case N_Others_Choice:
1925               break;
1926
1927             default:
1928               gcc_unreachable ();
1929             }
1930
1931           /* If the case value is a subtype that raises Constraint_Error at
1932              run-time because of a wrong bound, then gnu_low or gnu_high is
1933              not translated into an INTEGER_CST.  In such a case, we need
1934              to ensure that the when statement is not added in the tree,
1935              otherwise it will crash the gimplifier.  */
1936           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
1937               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
1938             {
1939               add_stmt_with_node (build3
1940                                   (CASE_LABEL_EXPR, void_type_node,
1941                                    gnu_low, gnu_high,
1942                                    create_artificial_label (input_location)),
1943                                   gnat_choice);
1944               choices_added++;
1945             }
1946         }
1947
1948       /* Push a binding level here in case variables are declared as we want
1949          them to be local to this set of statements instead of to the block
1950          containing the Case statement.  */
1951       if (choices_added > 0)
1952         {
1953           add_stmt (build_stmt_group (Statements (gnat_when), true));
1954           add_stmt (build1 (GOTO_EXPR, void_type_node,
1955                             TREE_VALUE (gnu_switch_label_stack)));
1956         }
1957     }
1958
1959   /* Now emit a definition of the label all the cases branched to.  */
1960   add_stmt (build1 (LABEL_EXPR, void_type_node,
1961                     TREE_VALUE (gnu_switch_label_stack)));
1962   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
1963                        end_stmt_group (), NULL_TREE);
1964   pop_stack (&gnu_switch_label_stack);
1965
1966   return gnu_result;
1967 }
1968 \f
1969 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
1970    to a GCC tree, which is returned.  */
1971
1972 static tree
1973 Loop_Statement_to_gnu (Node_Id gnat_node)
1974 {
1975   /* ??? It would be nice to use "build" here, but there's no build5.  */
1976   tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
1977                                  NULL_TREE, NULL_TREE, NULL_TREE);
1978   tree gnu_loop_var = NULL_TREE;
1979   Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
1980   tree gnu_cond_expr = NULL_TREE;
1981   tree gnu_result;
1982
1983   TREE_TYPE (gnu_loop_stmt) = void_type_node;
1984   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
1985   LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (input_location);
1986   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
1987   Sloc_to_locus (Sloc (End_Label (gnat_node)),
1988                  &DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt)));
1989
1990   /* Save the end label of this LOOP_STMT in a stack so that the corresponding
1991      N_Exit_Statement can find it.  */
1992   push_stack (&gnu_loop_label_stack, NULL_TREE,
1993               LOOP_STMT_LABEL (gnu_loop_stmt));
1994
1995   /* Set the condition under which the loop must keep going.
1996      For the case "LOOP .... END LOOP;" the condition is always true.  */
1997   if (No (gnat_iter_scheme))
1998     ;
1999
2000   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2001   else if (Present (Condition (gnat_iter_scheme)))
2002     LOOP_STMT_TOP_COND (gnu_loop_stmt)
2003       = gnat_to_gnu (Condition (gnat_iter_scheme));
2004
2005   /* Otherwise we have an iteration scheme and the condition is given by
2006      the bounds of the subtype of the iteration variable.  */
2007   else
2008     {
2009       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2010       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2011       Entity_Id gnat_type = Etype (gnat_loop_var);
2012       tree gnu_type = get_unpadded_type (gnat_type);
2013       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2014       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2015       tree gnu_first, gnu_last, gnu_limit;
2016       enum tree_code update_code, end_code;
2017       tree gnu_base_type = get_base_type (gnu_type);
2018
2019       /* We must disable modulo reduction for the loop variable, if any,
2020          in order for the loop comparison to be effective.  */
2021       if (Reverse_Present (gnat_loop_spec))
2022         {
2023           gnu_first = gnu_high;
2024           gnu_last = gnu_low;
2025           update_code = MINUS_NOMOD_EXPR;
2026           end_code = GE_EXPR;
2027           gnu_limit = TYPE_MIN_VALUE (gnu_base_type);
2028         }
2029       else
2030         {
2031           gnu_first = gnu_low;
2032           gnu_last = gnu_high;
2033           update_code = PLUS_NOMOD_EXPR;
2034           end_code = LE_EXPR;
2035           gnu_limit = TYPE_MAX_VALUE (gnu_base_type);
2036         }
2037
2038       /* We know the loop variable will not overflow if GNU_LAST is a constant
2039          and is not equal to GNU_LIMIT.  If it might overflow, we have to move
2040          the limit test to the end of the loop.  In that case, we have to test
2041          for an empty loop outside the loop.  */
2042       if (TREE_CODE (gnu_last) != INTEGER_CST
2043           || TREE_CODE (gnu_limit) != INTEGER_CST
2044           || tree_int_cst_equal (gnu_last, gnu_limit))
2045         {
2046           gnu_cond_expr
2047             = build3 (COND_EXPR, void_type_node,
2048                       build_binary_op (LE_EXPR, integer_type_node,
2049                                        gnu_low, gnu_high),
2050                       NULL_TREE, alloc_stmt_list ());
2051           set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2052         }
2053
2054       /* Open a new nesting level that will surround the loop to declare the
2055          loop index variable.  */
2056       start_stmt_group ();
2057       gnat_pushlevel ();
2058
2059       /* Declare the loop index and set it to its initial value.  */
2060       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2061       if (DECL_BY_REF_P (gnu_loop_var))
2062         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2063
2064       /* The loop variable might be a padded type, so use `convert' to get a
2065          reference to the inner variable if so.  */
2066       gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
2067
2068       /* Set either the top or bottom exit condition as appropriate depending
2069          on whether or not we know an overflow cannot occur.  */
2070       if (gnu_cond_expr)
2071         LOOP_STMT_BOT_COND (gnu_loop_stmt)
2072           = build_binary_op (NE_EXPR, integer_type_node,
2073                              gnu_loop_var, gnu_last);
2074       else
2075         LOOP_STMT_TOP_COND (gnu_loop_stmt)
2076           = build_binary_op (end_code, integer_type_node,
2077                              gnu_loop_var, gnu_last);
2078
2079       LOOP_STMT_UPDATE (gnu_loop_stmt)
2080         = build_binary_op (MODIFY_EXPR, NULL_TREE,
2081                            gnu_loop_var,
2082                            build_binary_op (update_code,
2083                                             TREE_TYPE (gnu_loop_var),
2084                                             gnu_loop_var,
2085                                             convert (TREE_TYPE (gnu_loop_var),
2086                                                      integer_one_node)));
2087       set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
2088                                    gnat_iter_scheme);
2089     }
2090
2091   /* If the loop was named, have the name point to this loop.  In this case,
2092      the association is not a ..._DECL node, but the end label from this
2093      LOOP_STMT.  */
2094   if (Present (Identifier (gnat_node)))
2095     save_gnu_tree (Entity (Identifier (gnat_node)),
2096                    LOOP_STMT_LABEL (gnu_loop_stmt), true);
2097
2098   /* Make the loop body into its own block, so any allocated storage will be
2099      released every iteration.  This is needed for stack allocation.  */
2100   LOOP_STMT_BODY (gnu_loop_stmt)
2101     = build_stmt_group (Statements (gnat_node), true);
2102
2103   /* If we declared a variable, then we are in a statement group for that
2104      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
2105   if (gnu_loop_var)
2106     {
2107       add_stmt (gnu_loop_stmt);
2108       gnat_poplevel ();
2109       gnu_loop_stmt = end_stmt_group ();
2110     }
2111
2112   /* If we have an outer COND_EXPR, that's our result and this loop is its
2113      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2114   if (gnu_cond_expr)
2115     {
2116       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2117       gnu_result = gnu_cond_expr;
2118       recalculate_side_effects (gnu_cond_expr);
2119     }
2120   else
2121     gnu_result = gnu_loop_stmt;
2122
2123   pop_stack (&gnu_loop_label_stack);
2124
2125   return gnu_result;
2126 }
2127 \f
2128 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2129    handler for the current function.  */
2130
2131 /* This is implemented by issuing a call to the appropriate VMS specific
2132    builtin.  To avoid having VMS specific sections in the global gigi decls
2133    array, we maintain the decls of interest here.  We can't declare them
2134    inside the function because we must mark them never to be GC'd, which we
2135    can only do at the global level.  */
2136
2137 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2138 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2139
2140 static void
2141 establish_gnat_vms_condition_handler (void)
2142 {
2143   tree establish_stmt;
2144
2145   /* Elaborate the required decls on the first call.  Check on the decl for
2146      the gnat condition handler to decide, as this is one we create so we are
2147      sure that it will be non null on subsequent calls.  The builtin decl is
2148      looked up so remains null on targets where it is not implemented yet.  */
2149   if (gnat_vms_condition_handler_decl == NULL_TREE)
2150     {
2151       vms_builtin_establish_handler_decl
2152         = builtin_decl_for
2153           (get_identifier ("__builtin_establish_vms_condition_handler"));
2154
2155       gnat_vms_condition_handler_decl
2156         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2157                                NULL_TREE,
2158                                build_function_type_list (integer_type_node,
2159                                                          ptr_void_type_node,
2160                                                          ptr_void_type_node,
2161                                                          NULL_TREE),
2162                                NULL_TREE, 0, 1, 1, 0, Empty);
2163
2164       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2165       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2166     }
2167
2168   /* Do nothing if the establish builtin is not available, which might happen
2169      on targets where the facility is not implemented.  */
2170   if (vms_builtin_establish_handler_decl == NULL_TREE)
2171     return;
2172
2173   establish_stmt
2174     = build_call_1_expr (vms_builtin_establish_handler_decl,
2175                          build_unary_op
2176                          (ADDR_EXPR, NULL_TREE,
2177                           gnat_vms_condition_handler_decl));
2178
2179   add_stmt (establish_stmt);
2180 }
2181 \f
2182 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
2183    don't return anything.  */
2184
2185 static void
2186 Subprogram_Body_to_gnu (Node_Id gnat_node)
2187 {
2188   /* Defining identifier of a parameter to the subprogram.  */
2189   Entity_Id gnat_param;
2190   /* The defining identifier for the subprogram body. Note that if a
2191      specification has appeared before for this body, then the identifier
2192      occurring in that specification will also be a defining identifier and all
2193      the calls to this subprogram will point to that specification.  */
2194   Entity_Id gnat_subprog_id
2195     = (Present (Corresponding_Spec (gnat_node))
2196        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2197   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
2198   tree gnu_subprog_decl;
2199   /* Its RESULT_DECL node.  */
2200   tree gnu_result_decl;
2201   /* The FUNCTION_TYPE node corresponding to the subprogram spec.  */
2202   tree gnu_subprog_type;
2203   tree gnu_cico_list;
2204   tree gnu_result;
2205   VEC(parm_attr,gc) *cache;
2206
2207   /* If this is a generic object or if it has been eliminated,
2208      ignore it.  */
2209   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2210       || Ekind (gnat_subprog_id) == E_Generic_Function
2211       || Is_Eliminated (gnat_subprog_id))
2212     return;
2213
2214   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
2215      the already-elaborated tree node.  However, if this subprogram had its
2216      elaboration deferred, we will already have made a tree node for it.  So
2217      treat it as not being defined in that case.  Such a subprogram cannot
2218      have an address clause or a freeze node, so this test is safe, though it
2219      does disable some otherwise-useful error checking.  */
2220   gnu_subprog_decl
2221     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2222                           Acts_As_Spec (gnat_node)
2223                           && !present_gnu_tree (gnat_subprog_id));
2224   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
2225   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2226
2227   /* If the function returns by invisible reference, make it explicit in the
2228      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.  */
2229   if (TREE_ADDRESSABLE (gnu_subprog_type))
2230     {
2231       TREE_TYPE (gnu_result_decl)
2232         = build_reference_type (TREE_TYPE (gnu_result_decl));
2233       relayout_decl (gnu_result_decl);
2234     }
2235
2236   /* Propagate the debug mode.  */
2237   if (!Needs_Debug_Info (gnat_subprog_id))
2238     DECL_IGNORED_P (gnu_subprog_decl) = 1;
2239
2240   /* Set the line number in the decl to correspond to that of the body so that
2241      the line number notes are written correctly.  */
2242   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
2243
2244   /* Initialize the information structure for the function.  */
2245   allocate_struct_function (gnu_subprog_decl, false);
2246   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
2247     = GGC_CNEW (struct language_function);
2248
2249   begin_subprog_body (gnu_subprog_decl);
2250   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2251
2252   /* If there are Out parameters, we need to ensure that the return statement
2253      properly copies them out.  We do this by making a new block and converting
2254      any inner return into a goto to a label at the end of the block.  */
2255   push_stack (&gnu_return_label_stack, NULL_TREE,
2256               gnu_cico_list ? create_artificial_label (input_location)
2257               : NULL_TREE);
2258
2259   /* Get a tree corresponding to the code for the subprogram.  */
2260   start_stmt_group ();
2261   gnat_pushlevel ();
2262
2263   /* See if there are any parameters for which we don't yet have GCC entities.
2264      These must be for Out parameters for which we will be making VAR_DECL
2265      nodes here.  Fill them in to TYPE_CI_CO_LIST, which must contain the empty
2266      entry as well.  We can match up the entries because TYPE_CI_CO_LIST is in
2267      the order of the parameters.  */
2268   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2269        Present (gnat_param);
2270        gnat_param = Next_Formal_With_Extras (gnat_param))
2271     if (!present_gnu_tree (gnat_param))
2272       {
2273         /* Skip any entries that have been already filled in; they must
2274            correspond to In Out parameters.  */
2275         for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
2276              gnu_cico_list = TREE_CHAIN (gnu_cico_list))
2277           ;
2278
2279         /* Do any needed references for padded types.  */
2280         TREE_VALUE (gnu_cico_list)
2281           = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
2282                      gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2283       }
2284
2285   /* On VMS, establish our condition handler to possibly turn a condition into
2286      the corresponding exception if the subprogram has a foreign convention or
2287      is exported.
2288
2289      To ensure proper execution of local finalizations on condition instances,
2290      we must turn a condition into the corresponding exception even if there
2291      is no applicable Ada handler, and need at least one condition handler per
2292      possible call chain involving GNAT code.  OTOH, establishing the handler
2293      has a cost so we want to minimize the number of subprograms into which
2294      this happens.  The foreign or exported condition is expected to satisfy
2295      all the constraints.  */
2296   if (TARGET_ABI_OPEN_VMS
2297       && (Has_Foreign_Convention (gnat_subprog_id)
2298           || Is_Exported (gnat_subprog_id)))
2299     establish_gnat_vms_condition_handler ();
2300
2301   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
2302
2303   /* Generate the code of the subprogram itself.  A return statement will be
2304      present and any Out parameters will be handled there.  */
2305   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
2306   gnat_poplevel ();
2307   gnu_result = end_stmt_group ();
2308
2309   /* If we populated the parameter attributes cache, we need to make sure
2310      that the cached expressions are evaluated on all possible paths.  */
2311   cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
2312   if (cache)
2313     {
2314       struct parm_attr_d *pa;
2315       int i;
2316
2317       start_stmt_group ();
2318
2319       for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
2320         {
2321           if (pa->first)
2322             add_stmt_with_node (pa->first, gnat_node);
2323           if (pa->last)
2324             add_stmt_with_node (pa->last, gnat_node);
2325           if (pa->length)
2326             add_stmt_with_node (pa->length, gnat_node);
2327         }
2328
2329       add_stmt (gnu_result);
2330       gnu_result = end_stmt_group ();
2331     }
2332
2333     /* If we are dealing with a return from an Ada procedure with parameters
2334        passed by copy-in/copy-out, we need to return a record containing the
2335        final values of these parameters.  If the list contains only one entry,
2336        return just that entry though.
2337
2338        For a full description of the copy-in/copy-out parameter mechanism, see
2339        the part of the gnat_to_gnu_entity routine dealing with the translation
2340        of subprograms.
2341
2342        We need to make a block that contains the definition of that label and
2343        the copying of the return value.  It first contains the function, then
2344        the label and copy statement.  */
2345   if (TREE_VALUE (gnu_return_label_stack))
2346     {
2347       tree gnu_retval;
2348
2349       start_stmt_group ();
2350       gnat_pushlevel ();
2351       add_stmt (gnu_result);
2352       add_stmt (build1 (LABEL_EXPR, void_type_node,
2353                         TREE_VALUE (gnu_return_label_stack)));
2354
2355       gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2356       if (list_length (gnu_cico_list) == 1)
2357         gnu_retval = TREE_VALUE (gnu_cico_list);
2358       else
2359         gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2360                                              gnu_cico_list);
2361
2362       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
2363                           End_Label (Handled_Statement_Sequence (gnat_node)));
2364       gnat_poplevel ();
2365       gnu_result = end_stmt_group ();
2366     }
2367
2368   pop_stack (&gnu_return_label_stack);
2369
2370   /* Set the end location.  */
2371   Sloc_to_locus
2372     ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
2373       ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
2374       : Sloc (gnat_node)),
2375      &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
2376
2377   end_subprog_body (gnu_result);
2378
2379   /* Finally annotate the parameters and disconnect the trees for parameters
2380      that we have turned into variables since they are now unusable.  */
2381   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2382        Present (gnat_param);
2383        gnat_param = Next_Formal_With_Extras (gnat_param))
2384     {
2385       tree gnu_param = get_gnu_tree (gnat_param);
2386       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
2387                        DECL_BY_REF_P (gnu_param));
2388       if (TREE_CODE (gnu_param) == VAR_DECL)
2389         save_gnu_tree (gnat_param, NULL_TREE, false);
2390     }
2391
2392   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2393     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2394
2395   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2396 }
2397 \f
2398 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2399    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2400    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2401    If GNU_TARGET is non-null, this must be a function call and the result
2402    of the call is to be placed into that object.  */
2403
2404 static tree
2405 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2406 {
2407   tree gnu_result;
2408   /* The GCC node corresponding to the GNAT subprogram name.  This can either
2409      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2410      or an indirect reference expression (an INDIRECT_REF node) pointing to a
2411      subprogram.  */
2412   tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
2413   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2414   tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
2415   tree gnu_subprog_addr
2416     = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node);
2417   Entity_Id gnat_formal;
2418   Node_Id gnat_actual;
2419   tree gnu_actual_list = NULL_TREE;
2420   tree gnu_name_list = NULL_TREE;
2421   tree gnu_before_list = NULL_TREE;
2422   tree gnu_after_list = NULL_TREE;
2423   tree gnu_subprog_call;
2424
2425   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2426
2427   /* If we are calling a stubbed function, make this into a raise of
2428      Program_Error.  Elaborate all our args first.  */
2429   if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
2430       && DECL_STUBBED_P (gnu_subprog_node))
2431     {
2432       for (gnat_actual = First_Actual (gnat_node);
2433            Present (gnat_actual);
2434            gnat_actual = Next_Actual (gnat_actual))
2435         add_stmt (gnat_to_gnu (gnat_actual));
2436
2437       {
2438         tree call_expr
2439           = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node,
2440                               N_Raise_Program_Error);
2441
2442         if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
2443           {
2444             *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
2445             return build1 (NULL_EXPR, *gnu_result_type_p, call_expr);
2446           }
2447         else
2448           return call_expr;
2449       }
2450     }
2451
2452   /* The only way we can be making a call via an access type is if Name is an
2453      explicit dereference.  In that case, get the list of formal args from the
2454      type the access type is pointing to.  Otherwise, get the formals from
2455      entity being called.  */
2456   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2457     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2458   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2459     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2460     gnat_formal = 0;
2461   else
2462     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2463
2464   /* Create the list of the actual parameters as GCC expects it, namely a chain
2465      of TREE_LIST nodes in which the TREE_VALUE field of each node is a
2466      parameter-expression and the TREE_PURPOSE field is null.  Skip Out
2467      parameters not passed by reference and don't need to be copied in.  */
2468   for (gnat_actual = First_Actual (gnat_node);
2469        Present (gnat_actual);
2470        gnat_formal = Next_Formal_With_Extras (gnat_formal),
2471        gnat_actual = Next_Actual (gnat_actual))
2472     {
2473       tree gnu_formal
2474         = (present_gnu_tree (gnat_formal)
2475            ? get_gnu_tree (gnat_formal) : NULL_TREE);
2476       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2477       /* We must suppress conversions that can cause the creation of a
2478          temporary in the Out or In Out case because we need the real
2479          object in this case, either to pass its address if it's passed
2480          by reference or as target of the back copy done after the call
2481          if it uses the copy-in copy-out mechanism.  We do it in the In
2482          case too, except for an unchecked conversion because it alone
2483          can cause the actual to be misaligned and the addressability
2484          test is applied to the real object.  */
2485       bool suppress_type_conversion
2486         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2487             && Ekind (gnat_formal) != E_In_Parameter)
2488            || (Nkind (gnat_actual) == N_Type_Conversion
2489                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2490       Node_Id gnat_name = (suppress_type_conversion
2491                            ? Expression (gnat_actual) : gnat_actual);
2492       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2493       tree gnu_actual;
2494
2495       /* If it's possible we may need to use this expression twice, make sure
2496          that any side-effects are handled via SAVE_EXPRs.  Likewise if we need
2497          to force side-effects before the call.
2498          ??? This is more conservative than we need since we don't need to do
2499          this for pass-by-ref with no conversion.  */
2500       if (Ekind (gnat_formal) != E_In_Parameter)
2501         gnu_name = gnat_stabilize_reference (gnu_name, true);
2502
2503       /* If we are passing a non-addressable parameter by reference, pass the
2504          address of a copy.  In the Out or In Out case, set up to copy back
2505          out after the call.  */
2506       if (gnu_formal
2507           && (DECL_BY_REF_P (gnu_formal)
2508               || (TREE_CODE (gnu_formal) == PARM_DECL
2509                   && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2510                       || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2511           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2512           && !addressable_p (gnu_name, gnu_name_type))
2513         {
2514           tree gnu_copy = gnu_name;
2515
2516           /* If the type is by_reference, a copy is not allowed.  */
2517           if (Is_By_Reference_Type (Etype (gnat_formal)))
2518             post_error
2519               ("misaligned actual cannot be passed by reference", gnat_actual);
2520
2521           /* For users of Starlet we issue a warning because the
2522              interface apparently assumes that by-ref parameters
2523              outlive the procedure invocation.  The code still
2524              will not work as intended, but we cannot do much
2525              better since other low-level parts of the back-end
2526              would allocate temporaries at will because of the
2527              misalignment if we did not do so here.  */
2528           else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2529             {
2530               post_error
2531                 ("?possible violation of implicit assumption", gnat_actual);
2532               post_error_ne
2533                 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
2534                  Entity (Name (gnat_node)));
2535               post_error_ne ("?because of misalignment of &", gnat_actual,
2536                              gnat_formal);
2537             }
2538
2539           /* If the actual type of the object is already the nominal type,
2540              we have nothing to do, except if the size is self-referential
2541              in which case we'll remove the unpadding below.  */
2542           if (TREE_TYPE (gnu_name) == gnu_name_type
2543               && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
2544             ;
2545
2546           /* Otherwise remove unpadding from the object and reset the copy.  */
2547           else if (TREE_CODE (gnu_name) == COMPONENT_REF
2548                    && TYPE_IS_PADDING_P
2549                       (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
2550             gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
2551
2552           /* Otherwise convert to the nominal type of the object if it's
2553              a record type.  There are several cases in which we need to
2554              make the temporary using this type instead of the actual type
2555              of the object if they are distinct, because the expectations
2556              of the callee would otherwise not be met:
2557                - if it's a justified modular type,
2558                - if the actual type is a smaller packable version of it.  */
2559           else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2560                    && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
2561                        || smaller_packable_type_p (TREE_TYPE (gnu_name),
2562                                                    gnu_name_type)))
2563             gnu_name = convert (gnu_name_type, gnu_name);
2564
2565           /* Make a SAVE_EXPR to both properly account for potential side
2566              effects and handle the creation of a temporary copy.  Special
2567              code in gnat_gimplify_expr ensures that the same temporary is
2568              used as the object and copied back after the call if needed.  */
2569           gnu_name = build1 (SAVE_EXPR, TREE_TYPE (gnu_name), gnu_name);
2570           TREE_SIDE_EFFECTS (gnu_name) = 1;
2571
2572           /* Set up to move the copy back to the original.  */
2573           if (Ekind (gnat_formal) != E_In_Parameter)
2574             {
2575               tree stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy,
2576                                            gnu_name);
2577               set_expr_location_from_node (stmt, gnat_node);
2578               append_to_statement_list (stmt, &gnu_after_list);
2579             }
2580         }
2581
2582       /* Start from the real object and build the actual.  */
2583       gnu_actual = gnu_name;
2584
2585       /* If this was a procedure call, we may not have removed any padding.
2586          So do it here for the part we will use as an input, if any.  */
2587       if (Ekind (gnat_formal) != E_Out_Parameter
2588           && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2589         gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2590                               gnu_actual);
2591
2592       /* Do any needed conversions for the actual and make sure that it is
2593          in range of the formal's type.  */
2594       if (suppress_type_conversion)
2595         {
2596           /* Put back the conversion we suppressed above in the computation
2597              of the real object.  Note that we treat a conversion between
2598              aggregate types as if it is an unchecked conversion here.  */
2599           gnu_actual
2600             = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2601                                  gnu_actual,
2602                                  (Nkind (gnat_actual)
2603                                   == N_Unchecked_Type_Conversion)
2604                                  && No_Truncation (gnat_actual));
2605
2606           if (Ekind (gnat_formal) != E_Out_Parameter
2607               && Do_Range_Check (gnat_actual))
2608             gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal),
2609                                            gnat_actual);
2610         }
2611       else
2612         {
2613           if (Ekind (gnat_formal) != E_Out_Parameter
2614               && Do_Range_Check (gnat_actual))
2615             gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal),
2616                                            gnat_actual);
2617
2618           /* We may have suppressed a conversion to the Etype of the actual
2619              since the parent is a procedure call.  So put it back here.
2620              ??? We use the reverse order compared to the case above because
2621              of an awkward interaction with the check and actually don't put
2622              back the conversion at all if a check is emitted.  This is also
2623              done for the conversion to the formal's type just below.  */
2624           if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2625             gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2626                                   gnu_actual);
2627         }
2628
2629       if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2630         gnu_actual = convert (gnu_formal_type, gnu_actual);
2631
2632       /* Unless this is an In parameter, we must remove any justified modular
2633          building from GNU_NAME to get an lvalue.  */
2634       if (Ekind (gnat_formal) != E_In_Parameter
2635           && TREE_CODE (gnu_name) == CONSTRUCTOR
2636           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2637           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2638         gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
2639                             gnu_name);
2640
2641       /* If we have not saved a GCC object for the formal, it means it is an
2642          Out parameter not passed by reference and that does not need to be
2643          copied in. Otherwise, look at the PARM_DECL to see if it is passed by
2644          reference.  */
2645       if (gnu_formal
2646           && TREE_CODE (gnu_formal) == PARM_DECL
2647           && DECL_BY_REF_P (gnu_formal))
2648         {
2649           if (Ekind (gnat_formal) != E_In_Parameter)
2650             {
2651               /* In Out or Out parameters passed by reference don't use the
2652                  copy-in copy-out mechanism so the address of the real object
2653                  must be passed to the function.  */
2654               gnu_actual = gnu_name;
2655
2656               /* If we have a padded type, be sure we've removed padding.  */
2657               if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
2658                   && TREE_CODE (gnu_actual) != SAVE_EXPR)
2659                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2660                                       gnu_actual);
2661
2662               /* If we have the constructed subtype of an aliased object
2663                  with an unconstrained nominal subtype, the type of the
2664                  actual includes the template, although it is formally
2665                  constrained.  So we need to convert it back to the real
2666                  constructed subtype to retrieve the constrained part
2667                  and takes its address.  */
2668               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2669                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
2670                   && TREE_CODE (gnu_actual) != SAVE_EXPR
2671                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
2672                   && Is_Array_Type (Etype (gnat_actual)))
2673                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2674                                       gnu_actual);
2675             }
2676
2677           /* The symmetry of the paths to the type of an entity is broken here
2678              since arguments don't know that they will be passed by ref.  */
2679           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2680           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2681         }
2682       else if (gnu_formal
2683                && TREE_CODE (gnu_formal) == PARM_DECL
2684                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
2685         {
2686           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2687           gnu_actual = maybe_implicit_deref (gnu_actual);
2688           gnu_actual = maybe_unconstrained_array (gnu_actual);
2689
2690           if (TYPE_IS_PADDING_P (gnu_formal_type))
2691             {
2692               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2693               gnu_actual = convert (gnu_formal_type, gnu_actual);
2694             }
2695
2696           /* Take the address of the object and convert to the proper pointer
2697              type.  We'd like to actually compute the address of the beginning
2698              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2699              possibility that the ARRAY_REF might return a constant and we'd be
2700              getting the wrong address.  Neither approach is exactly correct,
2701              but this is the most likely to work in all cases.  */
2702           gnu_actual = convert (gnu_formal_type,
2703                                 build_unary_op (ADDR_EXPR, NULL_TREE,
2704                                                 gnu_actual));
2705         }
2706       else if (gnu_formal
2707                && TREE_CODE (gnu_formal) == PARM_DECL
2708                && DECL_BY_DESCRIPTOR_P (gnu_formal))
2709         {
2710           /* If arg is 'Null_Parameter, pass zero descriptor.  */
2711           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2712                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2713               && TREE_PRIVATE (gnu_actual))
2714             gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
2715                                   integer_zero_node);
2716           else
2717             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
2718                                          fill_vms_descriptor (gnu_actual,
2719                                                               gnat_formal,
2720                                                               gnat_actual));
2721         }
2722       else
2723         {
2724           tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
2725
2726           if (Ekind (gnat_formal) != E_In_Parameter)
2727             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
2728
2729           if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL)
2730             continue;
2731
2732           /* If this is 'Null_Parameter, pass a zero even though we are
2733              dereferencing it.  */
2734           else if (TREE_CODE (gnu_actual) == INDIRECT_REF
2735                    && TREE_PRIVATE (gnu_actual)
2736                    && host_integerp (gnu_actual_size, 1)
2737                    && 0 >= compare_tree_int (gnu_actual_size,
2738                                                    BITS_PER_WORD))
2739             gnu_actual
2740               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
2741                                    convert (gnat_type_for_size
2742                                             (tree_low_cst (gnu_actual_size, 1),
2743                                              1),
2744                                             integer_zero_node),
2745                                    false);
2746           else
2747             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
2748         }
2749
2750       gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
2751     }
2752
2753   gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type),
2754                                       gnu_subprog_addr,
2755                                       nreverse (gnu_actual_list));
2756   set_expr_location_from_node (gnu_subprog_call, gnat_node);
2757
2758   /* If it's a function call, the result is the call expression unless a target
2759      is specified, in which case we copy the result into the target and return
2760      the assignment statement.  */
2761   if (Nkind (gnat_node) == N_Function_Call)
2762     {
2763       gnu_result = gnu_subprog_call;
2764       enum tree_code op_code;
2765
2766       /* If the function returns an unconstrained array or by direct reference,
2767          we have to dereference the pointer.  */
2768       if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
2769           || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
2770         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2771
2772       if (gnu_target)
2773         {
2774           /* ??? If the return type has non-constant size, then force the
2775              return slot optimization as we would not be able to generate
2776              a temporary.  That's what has been done historically.  */
2777           if (TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_subprog_type))))
2778             op_code = MODIFY_EXPR;
2779           else
2780             op_code = INIT_EXPR;
2781
2782           gnu_result
2783             = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result);
2784         }
2785       else
2786         *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
2787
2788       return gnu_result;
2789     }
2790
2791   /* If this is the case where the GNAT tree contains a procedure call but the
2792      Ada procedure has copy-in/copy-out parameters, then the special parameter
2793      passing mechanism must be used.  */
2794   if (TYPE_CI_CO_LIST (gnu_subprog_type))
2795     {
2796       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
2797          in copy out parameters.  */
2798       tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2799       int length = list_length (scalar_return_list);
2800
2801       if (length > 1)
2802         {
2803           tree gnu_name;
2804
2805           gnu_subprog_call = save_expr (gnu_subprog_call);
2806           gnu_name_list = nreverse (gnu_name_list);
2807
2808           /* If any of the names had side-effects, ensure they are all
2809              evaluated before the call.  */
2810           for (gnu_name = gnu_name_list; gnu_name;
2811                gnu_name = TREE_CHAIN (gnu_name))
2812             if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
2813               append_to_statement_list (TREE_VALUE (gnu_name),
2814                                         &gnu_before_list);
2815         }
2816
2817       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2818         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2819       else
2820         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2821
2822       for (gnat_actual = First_Actual (gnat_node);
2823            Present (gnat_actual);
2824            gnat_formal = Next_Formal_With_Extras (gnat_formal),
2825            gnat_actual = Next_Actual (gnat_actual))
2826         /* If we are dealing with a copy in copy out parameter, we must
2827            retrieve its value from the record returned in the call.  */
2828         if (!(present_gnu_tree (gnat_formal)
2829               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2830               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2831                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2832                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2833                            || (DECL_BY_DESCRIPTOR_P
2834                                (get_gnu_tree (gnat_formal))))))))
2835             && Ekind (gnat_formal) != E_In_Parameter)
2836           {
2837             /* Get the value to assign to this Out or In Out parameter.  It is
2838                either the result of the function if there is only a single such
2839                parameter or the appropriate field from the record returned.  */
2840             tree gnu_result
2841               = length == 1 ? gnu_subprog_call
2842                 : build_component_ref (gnu_subprog_call, NULL_TREE,
2843                                        TREE_PURPOSE (scalar_return_list),
2844                                        false);
2845
2846             /* If the actual is a conversion, get the inner expression, which
2847                will be the real destination, and convert the result to the
2848                type of the actual parameter.  */
2849             tree gnu_actual
2850               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
2851
2852             /* If the result is a padded type, remove the padding.  */
2853             if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
2854               gnu_result = convert (TREE_TYPE (TYPE_FIELDS
2855                                                (TREE_TYPE (gnu_result))),
2856                                     gnu_result);
2857
2858             /* If the actual is a type conversion, the real target object is
2859                denoted by the inner Expression and we need to convert the
2860                result to the associated type.
2861                We also need to convert our gnu assignment target to this type
2862                if the corresponding GNU_NAME was constructed from the GNAT
2863                conversion node and not from the inner Expression.  */
2864             if (Nkind (gnat_actual) == N_Type_Conversion)
2865               {
2866                 gnu_result
2867                   = convert_with_check
2868                     (Etype (Expression (gnat_actual)), gnu_result,
2869                      Do_Overflow_Check (gnat_actual),
2870                      Do_Range_Check (Expression (gnat_actual)),
2871                      Float_Truncate (gnat_actual), gnat_actual);
2872
2873                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
2874                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
2875               }
2876
2877             /* Unchecked conversions as actuals for Out parameters are not
2878                allowed in user code because they are not variables, but do
2879                occur in front-end expansions.  The associated GNU_NAME is
2880                always obtained from the inner expression in such cases.  */
2881             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2882               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
2883                                               gnu_result,
2884                                               No_Truncation (gnat_actual));
2885             else
2886               {
2887                 if (Do_Range_Check (gnat_actual))
2888                   gnu_result
2889                     = emit_range_check (gnu_result, Etype (gnat_actual),
2890                                         gnat_actual);
2891
2892                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2893                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
2894                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
2895               }
2896
2897             /* Undo wrapping of boolean rvalues.  */
2898             if (TREE_CODE (gnu_actual) == NE_EXPR
2899                 && TREE_CODE (get_base_type (TREE_TYPE (gnu_actual)))
2900                    == BOOLEAN_TYPE
2901                 && integer_zerop (TREE_OPERAND (gnu_actual, 1)))
2902               gnu_actual = TREE_OPERAND (gnu_actual, 0);
2903             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2904                                           gnu_actual, gnu_result);
2905             set_expr_location_from_node (gnu_result, gnat_node);
2906             append_to_statement_list (gnu_result, &gnu_before_list);
2907             scalar_return_list = TREE_CHAIN (scalar_return_list);
2908             gnu_name_list = TREE_CHAIN (gnu_name_list);
2909           }
2910         }
2911   else
2912     append_to_statement_list (gnu_subprog_call, &gnu_before_list);
2913
2914   append_to_statement_list (gnu_after_list, &gnu_before_list);
2915   return gnu_before_list;
2916 }
2917 \f
2918 /* Subroutine of gnat_to_gnu to translate gnat_node, an
2919    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
2920
2921 static tree
2922 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
2923 {
2924   tree gnu_jmpsave_decl = NULL_TREE;
2925   tree gnu_jmpbuf_decl = NULL_TREE;
2926   /* If just annotating, ignore all EH and cleanups.  */
2927   bool gcc_zcx = (!type_annotate_only
2928                   && Present (Exception_Handlers (gnat_node))
2929                   && Exception_Mechanism == Back_End_Exceptions);
2930   bool setjmp_longjmp
2931     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
2932        && Exception_Mechanism == Setjmp_Longjmp);
2933   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
2934   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
2935   tree gnu_inner_block; /* The statement(s) for the block itself.  */
2936   tree gnu_result;
2937   tree gnu_expr;
2938   Node_Id gnat_temp;
2939
2940   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
2941      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
2942      add_cleanup, and when we leave the binding, end_stmt_group will create
2943      the TRY_FINALLY_EXPR.
2944
2945      ??? The region level calls down there have been specifically put in place
2946      for a ZCX context and currently the order in which things are emitted
2947      (region/handlers) is different from the SJLJ case. Instead of putting
2948      other calls with different conditions at other places for the SJLJ case,
2949      it seems cleaner to reorder things for the SJLJ case and generalize the
2950      condition to make it not ZCX specific.
2951
2952      If there are any exceptions or cleanup processing involved, we need an
2953      outer statement group (for Setjmp_Longjmp) and binding level.  */
2954   if (binding_for_block)
2955     {
2956       start_stmt_group ();
2957       gnat_pushlevel ();
2958     }
2959
2960   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
2961      area for address of previous buffer.  Do this first since we need to have
2962      the setjmp buf known for any decls in this block.  */
2963   if (setjmp_longjmp)
2964     {
2965       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
2966                                           NULL_TREE, jmpbuf_ptr_type,
2967                                           build_call_0_expr (get_jmpbuf_decl),
2968                                           false, false, false, false, NULL,
2969                                           gnat_node);
2970       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
2971
2972       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
2973          because of the unstructured form of EH used by setjmp_longjmp, there
2974          might be forward edges going to __builtin_setjmp receivers on which
2975          it is uninitialized, although they will never be actually taken.  */
2976       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
2977       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
2978                                          NULL_TREE, jmpbuf_type,
2979                                          NULL_TREE, false, false, false, false,
2980                                          NULL, gnat_node);
2981       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
2982
2983       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
2984
2985       /* When we exit this block, restore the saved value.  */
2986       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
2987                    End_Label (gnat_node));
2988     }
2989
2990   /* If we are to call a function when exiting this block, add a cleanup
2991      to the binding level we made above.  Note that add_cleanup is FIFO
2992      so we must register this cleanup after the EH cleanup just above.  */
2993   if (at_end)
2994     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
2995                  End_Label (gnat_node));
2996
2997   /* Now build the tree for the declarations and statements inside this block.
2998      If this is SJLJ, set our jmp_buf as the current buffer.  */
2999   start_stmt_group ();
3000
3001   if (setjmp_longjmp)
3002     add_stmt (build_call_1_expr (set_jmpbuf_decl,
3003                                  build_unary_op (ADDR_EXPR, NULL_TREE,
3004                                                  gnu_jmpbuf_decl)));
3005
3006   if (Present (First_Real_Statement (gnat_node)))
3007     process_decls (Statements (gnat_node), Empty,
3008                    First_Real_Statement (gnat_node), true, true);
3009
3010   /* Generate code for each statement in the block.  */
3011   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3012                     ? First_Real_Statement (gnat_node)
3013                     : First (Statements (gnat_node)));
3014        Present (gnat_temp); gnat_temp = Next (gnat_temp))
3015     add_stmt (gnat_to_gnu (gnat_temp));
3016   gnu_inner_block = end_stmt_group ();
3017
3018   /* Now generate code for the two exception models, if either is relevant for
3019      this block.  */
3020   if (setjmp_longjmp)
3021     {
3022       tree *gnu_else_ptr = 0;
3023       tree gnu_handler;
3024
3025       /* Make a binding level for the exception handling declarations and code
3026          and set up gnu_except_ptr_stack for the handlers to use.  */
3027       start_stmt_group ();
3028       gnat_pushlevel ();
3029
3030       push_stack (&gnu_except_ptr_stack, NULL_TREE,
3031                   create_var_decl (get_identifier ("EXCEPT_PTR"),
3032                                    NULL_TREE,
3033                                    build_pointer_type (except_type_node),
3034                                    build_call_0_expr (get_excptr_decl), false,
3035                                    false, false, false, NULL, gnat_node));
3036
3037       /* Generate code for each handler. The N_Exception_Handler case does the
3038          real work and returns a COND_EXPR for each handler, which we chain
3039          together here.  */
3040       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3041            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
3042         {
3043           gnu_expr = gnat_to_gnu (gnat_temp);
3044
3045           /* If this is the first one, set it as the outer one. Otherwise,
3046              point the "else" part of the previous handler to us. Then point
3047              to our "else" part.  */
3048           if (!gnu_else_ptr)
3049             add_stmt (gnu_expr);
3050           else
3051             *gnu_else_ptr = gnu_expr;
3052
3053           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3054         }
3055
3056       /* If none of the exception handlers did anything, re-raise but do not
3057          defer abortion.  */
3058       gnu_expr = build_call_1_expr (raise_nodefer_decl,
3059                                     TREE_VALUE (gnu_except_ptr_stack));
3060       set_expr_location_from_node
3061         (gnu_expr,
3062          Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
3063
3064       if (gnu_else_ptr)
3065         *gnu_else_ptr = gnu_expr;
3066       else
3067         add_stmt (gnu_expr);
3068
3069       /* End the binding level dedicated to the exception handlers and get the
3070          whole statement group.  */
3071       pop_stack (&gnu_except_ptr_stack);
3072       gnat_poplevel ();
3073       gnu_handler = end_stmt_group ();
3074
3075       /* If the setjmp returns 1, we restore our incoming longjmp value and
3076          then check the handlers.  */
3077       start_stmt_group ();
3078       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
3079                                              gnu_jmpsave_decl),
3080                           gnat_node);
3081       add_stmt (gnu_handler);
3082       gnu_handler = end_stmt_group ();
3083
3084       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
3085       gnu_result = build3 (COND_EXPR, void_type_node,
3086                         &nbs