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