OSDN Git Service

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