gcc/ada/gcc-interface/trans.c

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