OSDN Git Service

* gcc-interface/trans.c (Identifier_to_gnu): Use boolean variable.
[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       bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1001                             && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1002
1003       /* If there is a (corresponding) variable, we only want to return
1004          the constant value if an lvalue is not required.  Evaluate this
1005          now if we have not already done so.  */
1006       if (!constant_only && require_lvalue < 0)
1007         require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
1008                                             Is_Aliased (gnat_temp));
1009
1010       if (constant_only || !require_lvalue)
1011         gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
1012     }
1013
1014   *gnu_result_type_p = gnu_result_type;
1015   return gnu_result;
1016 }
1017 \f
1018 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma.  Return
1019    any statements we generate.  */
1020
1021 static tree
1022 Pragma_to_gnu (Node_Id gnat_node)
1023 {
1024   Node_Id gnat_temp;
1025   tree gnu_result = alloc_stmt_list ();
1026
1027   /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1028      annotating types.  */
1029   if (type_annotate_only
1030       || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1031     return gnu_result;
1032
1033   switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1034     {
1035     case Pragma_Inspection_Point:
1036       /* Do nothing at top level: all such variables are already viewable.  */
1037       if (global_bindings_p ())
1038         break;
1039
1040       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1041            Present (gnat_temp);
1042            gnat_temp = Next (gnat_temp))
1043         {
1044           Node_Id gnat_expr = Expression (gnat_temp);
1045           tree gnu_expr = gnat_to_gnu (gnat_expr);
1046           int use_address;
1047           enum machine_mode mode;
1048           tree asm_constraint = NULL_TREE;
1049 #ifdef ASM_COMMENT_START
1050           char *comment;
1051 #endif
1052
1053           if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1054             gnu_expr = TREE_OPERAND (gnu_expr, 0);
1055
1056           /* Use the value only if it fits into a normal register,
1057              otherwise use the address.  */
1058           mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1059           use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1060                           && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1061                          || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1062
1063           if (use_address)
1064             gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1065
1066 #ifdef ASM_COMMENT_START
1067           comment = concat (ASM_COMMENT_START,
1068                             " inspection point: ",
1069                             Get_Name_String (Chars (gnat_expr)),
1070                             use_address ? " address" : "",
1071                             " is in %0",
1072                             NULL);
1073           asm_constraint = build_string (strlen (comment), comment);
1074           free (comment);
1075 #endif
1076           gnu_expr = build5 (ASM_EXPR, void_type_node,
1077                              asm_constraint,
1078                              NULL_TREE,
1079                              tree_cons
1080                              (build_tree_list (NULL_TREE,
1081                                                build_string (1, "g")),
1082                               gnu_expr, NULL_TREE),
1083                              NULL_TREE, NULL_TREE);
1084           ASM_VOLATILE_P (gnu_expr) = 1;
1085           set_expr_location_from_node (gnu_expr, gnat_node);
1086           append_to_statement_list (gnu_expr, &gnu_result);
1087         }
1088       break;
1089
1090     case Pragma_Optimize:
1091       switch (Chars (Expression
1092                      (First (Pragma_Argument_Associations (gnat_node)))))
1093         {
1094         case Name_Time:  case Name_Space:
1095           if (!optimize)
1096             post_error ("insufficient -O value?", gnat_node);
1097           break;
1098
1099         case Name_Off:
1100           if (optimize)
1101             post_error ("must specify -O0?", gnat_node);
1102           break;
1103
1104         default:
1105           gcc_unreachable ();
1106         }
1107       break;
1108
1109     case Pragma_Reviewable:
1110       if (write_symbols == NO_DEBUG)
1111         post_error ("must specify -g?", gnat_node);
1112       break;
1113     }
1114
1115   return gnu_result;
1116 }
1117 \f
1118 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1119    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
1120    where we should place the result type.  ATTRIBUTE is the attribute ID.  */
1121
1122 static tree
1123 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1124 {
1125   tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1126   tree gnu_type = TREE_TYPE (gnu_prefix);
1127   tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1128   bool prefix_unused = false;
1129
1130   /* If the input is a NULL_EXPR, make a new one.  */
1131   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1132     {
1133       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1134       *gnu_result_type_p = gnu_result_type;
1135       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1136     }
1137
1138   switch (attribute)
1139     {
1140     case Attr_Pos:
1141     case Attr_Val:
1142       /* These are just conversions since representation clauses for
1143          enumeration types are handled in the front-end.  */
1144       {
1145         bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1146         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1147         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1148         gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1149                                          checkp, checkp, true, gnat_node);
1150       }
1151       break;
1152
1153     case Attr_Pred:
1154     case Attr_Succ:
1155       /* These just add or subtract the constant 1 since representation
1156          clauses for enumeration types are handled in the front-end.  */
1157       gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1158       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1159
1160       if (Do_Range_Check (First (Expressions (gnat_node))))
1161         {
1162           gnu_expr = gnat_protect_expr (gnu_expr);
1163           gnu_expr
1164             = emit_check
1165               (build_binary_op (EQ_EXPR, integer_type_node,
1166                                 gnu_expr,
1167                                 attribute == Attr_Pred
1168                                 ? TYPE_MIN_VALUE (gnu_result_type)
1169                                 : TYPE_MAX_VALUE (gnu_result_type)),
1170                gnu_expr, CE_Range_Check_Failed, gnat_node);
1171         }
1172
1173       gnu_result
1174         = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1175                            gnu_result_type, gnu_expr,
1176                            convert (gnu_result_type, integer_one_node));
1177       break;
1178
1179     case Attr_Address:
1180     case Attr_Unrestricted_Access:
1181       /* Conversions don't change addresses but can cause us to miss the
1182          COMPONENT_REF case below, so strip them off.  */
1183       gnu_prefix = remove_conversions (gnu_prefix,
1184                                        !Must_Be_Byte_Aligned (gnat_node));
1185
1186       /* If we are taking 'Address of an unconstrained object, this is the
1187          pointer to the underlying array.  */
1188       if (attribute == Attr_Address)
1189         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1190
1191       /* If we are building a static dispatch table, we have to honor
1192          TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1193          with the C++ ABI.  We do it in the non-static case as well,
1194          see gnat_to_gnu_entity, case E_Access_Subprogram_Type.  */
1195       else if (TARGET_VTABLE_USES_DESCRIPTORS
1196                && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1197         {
1198           tree gnu_field, gnu_list = NULL_TREE, t;
1199           /* Descriptors can only be built here for top-level functions.  */
1200           bool build_descriptor = (global_bindings_p () != 0);
1201           int i;
1202
1203           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1204
1205           /* If we're not going to build the descriptor, we have to retrieve
1206              the one which will be built by the linker (or by the compiler
1207              later if a static chain is requested).  */
1208           if (!build_descriptor)
1209             {
1210               gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1211               gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1212                                          gnu_result);
1213               gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1214             }
1215
1216           for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1217                i < TARGET_VTABLE_USES_DESCRIPTORS;
1218                gnu_field = TREE_CHAIN (gnu_field), i++)
1219             {
1220               if (build_descriptor)
1221                 {
1222                   t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1223                               build_int_cst (NULL_TREE, i));
1224                   TREE_CONSTANT (t) = 1;
1225                 }
1226               else
1227                 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1228                             gnu_field, NULL_TREE);
1229
1230               gnu_list = tree_cons (gnu_field, t, gnu_list);
1231             }
1232
1233           gnu_result = gnat_build_constructor (gnu_result_type, gnu_list);
1234           break;
1235         }
1236
1237       /* ... fall through ... */
1238
1239     case Attr_Access:
1240     case Attr_Unchecked_Access:
1241     case Attr_Code_Address:
1242       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1243       gnu_result
1244         = build_unary_op (((attribute == Attr_Address
1245                             || attribute == Attr_Unrestricted_Access)
1246                            && !Must_Be_Byte_Aligned (gnat_node))
1247                           ? ATTR_ADDR_EXPR : ADDR_EXPR,
1248                           gnu_result_type, gnu_prefix);
1249
1250       /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1251          don't try to build a trampoline.  */
1252       if (attribute == Attr_Code_Address)
1253         {
1254           for (gnu_expr = gnu_result;
1255                CONVERT_EXPR_P (gnu_expr);
1256                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1257             TREE_CONSTANT (gnu_expr) = 1;
1258
1259           if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1260             TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1261         }
1262
1263       /* For other address attributes applied to a nested function,
1264          find an inner ADDR_EXPR and annotate it so that we can issue
1265          a useful warning with -Wtrampolines.  */
1266       else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1267         {
1268           for (gnu_expr = gnu_result;
1269                CONVERT_EXPR_P (gnu_expr);
1270                gnu_expr = TREE_OPERAND (gnu_expr, 0))
1271             ;
1272
1273           if (TREE_CODE (gnu_expr) == ADDR_EXPR
1274               && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1275             {
1276               set_expr_location_from_node (gnu_expr, gnat_node);
1277
1278               /* Check that we're not violating the No_Implicit_Dynamic_Code
1279                  restriction.  Be conservative if we don't know anything
1280                  about the trampoline strategy for the target.  */
1281               Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1282             }
1283         }
1284       break;
1285
1286     case Attr_Pool_Address:
1287       {
1288         tree gnu_obj_type;
1289         tree gnu_ptr = gnu_prefix;
1290
1291         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1292
1293         /* If this is an unconstrained array, we know the object has been
1294            allocated with the template in front of the object.  So compute
1295            the template address.  */
1296         if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1297           gnu_ptr
1298             = convert (build_pointer_type
1299                        (TYPE_OBJECT_RECORD_TYPE
1300                         (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1301                        gnu_ptr);
1302
1303         gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1304         if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1305             && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1306           {
1307             tree gnu_char_ptr_type = build_pointer_type (char_type_node);
1308             tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1309             tree gnu_byte_offset
1310               = convert (sizetype,
1311                          size_diffop (size_zero_node, gnu_pos));
1312             gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
1313
1314             gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1315             gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1316                                        gnu_ptr, gnu_byte_offset);
1317           }
1318
1319         gnu_result = convert (gnu_result_type, gnu_ptr);
1320       }
1321       break;
1322
1323     case Attr_Size:
1324     case Attr_Object_Size:
1325     case Attr_Value_Size:
1326     case Attr_Max_Size_In_Storage_Elements:
1327       gnu_expr = gnu_prefix;
1328
1329       /* Remove NOPs and conversions between original and packable version
1330          from GNU_EXPR, and conversions from GNU_PREFIX.  We use GNU_EXPR
1331          to see if a COMPONENT_REF was involved.  */
1332       while (TREE_CODE (gnu_expr) == NOP_EXPR
1333              || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1334                  && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1335                  && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1336                     == RECORD_TYPE
1337                  && TYPE_NAME (TREE_TYPE (gnu_expr))
1338                     == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1339         gnu_expr = TREE_OPERAND (gnu_expr, 0);
1340
1341       gnu_prefix = remove_conversions (gnu_prefix, true);
1342       prefix_unused = true;
1343       gnu_type = TREE_TYPE (gnu_prefix);
1344
1345       /* Replace an unconstrained array type with the type of the underlying
1346          array.  We can't do this with a call to maybe_unconstrained_array
1347          since we may have a TYPE_DECL.  For 'Max_Size_In_Storage_Elements,
1348          use the record type that will be used to allocate the object and its
1349          template.  */
1350       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1351         {
1352           gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1353           if (attribute != Attr_Max_Size_In_Storage_Elements)
1354             gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1355         }
1356
1357       /* If we're looking for the size of a field, return the field size.
1358          Otherwise, if the prefix is an object, or if we're looking for
1359          'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1360          GCC size of the type.  Otherwise, it is the RM size of the type.  */
1361       if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1362         gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1363       else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1364                || attribute == Attr_Object_Size
1365                || attribute == Attr_Max_Size_In_Storage_Elements)
1366         {
1367           /* If the prefix is an object of a padded type, the GCC size isn't
1368              relevant to the programmer.  Normally what we want is the RM size,
1369              which was set from the specified size, but if it was not set, we
1370              want the size of the field.  Using the MAX of those two produces
1371              the right result in all cases.  Don't use the size of the field
1372              if it's self-referential, since that's never what's wanted.  */
1373           if (TREE_CODE (gnu_prefix) != TYPE_DECL
1374               && TYPE_IS_PADDING_P (gnu_type)
1375               && TREE_CODE (gnu_expr) == COMPONENT_REF)
1376             {
1377               gnu_result = rm_size (gnu_type);
1378               if (!CONTAINS_PLACEHOLDER_P
1379                    (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1380                 gnu_result
1381                   = size_binop (MAX_EXPR, gnu_result,
1382                                 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1383             }
1384           else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1385             {
1386               Node_Id gnat_deref = Prefix (gnat_node);
1387               Node_Id gnat_actual_subtype
1388                 = Actual_Designated_Subtype (gnat_deref);
1389               tree gnu_ptr_type
1390                 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1391
1392               if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1393                   && Present (gnat_actual_subtype))
1394                 {
1395                   tree gnu_actual_obj_type
1396                     = gnat_to_gnu_type (gnat_actual_subtype);
1397                   gnu_type
1398                     = build_unc_object_type_from_ptr (gnu_ptr_type,
1399                                                       gnu_actual_obj_type,
1400                                                       get_identifier ("SIZE"));
1401                 }
1402
1403               gnu_result = TYPE_SIZE (gnu_type);
1404             }
1405           else
1406             gnu_result = TYPE_SIZE (gnu_type);
1407         }
1408       else
1409         gnu_result = rm_size (gnu_type);
1410
1411       gcc_assert (gnu_result);
1412
1413       /* Deal with a self-referential size by returning the maximum size for
1414          a type and by qualifying the size with the object for 'Size of an
1415          object.  */
1416       if (CONTAINS_PLACEHOLDER_P (gnu_result))
1417         {
1418           if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1419             gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1420           else
1421             gnu_result = max_size (gnu_result, true);
1422         }
1423
1424       /* If the type contains a template, subtract its size.  */
1425       if (TREE_CODE (gnu_type) == RECORD_TYPE
1426           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1427         gnu_result = size_binop (MINUS_EXPR, gnu_result,
1428                                  DECL_SIZE (TYPE_FIELDS (gnu_type)));
1429
1430       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1431
1432       if (attribute == Attr_Max_Size_In_Storage_Elements)
1433         gnu_result = fold_build2 (CEIL_DIV_EXPR, bitsizetype,
1434                                   gnu_result, bitsize_unit_node);
1435       break;
1436
1437     case Attr_Alignment:
1438       {
1439         unsigned int align;
1440
1441         if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1442             && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1443           gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1444
1445         gnu_type = TREE_TYPE (gnu_prefix);
1446         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1447         prefix_unused = true;
1448
1449         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1450           align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1451         else
1452           {
1453             Node_Id gnat_prefix = Prefix (gnat_node);
1454             Entity_Id gnat_type = Etype (gnat_prefix);
1455             unsigned int double_align;
1456             bool is_capped_double, align_clause;
1457
1458             /* If the default alignment of "double" or larger scalar types is
1459                specifically capped and there is an alignment clause neither
1460                on the type nor on the prefix itself, return the cap.  */
1461             if ((double_align = double_float_alignment) > 0)
1462               is_capped_double
1463                 = is_double_float_or_array (gnat_type, &align_clause);
1464             else if ((double_align = double_scalar_alignment) > 0)
1465               is_capped_double
1466                 = is_double_scalar_or_array (gnat_type, &align_clause);
1467             else
1468               is_capped_double = align_clause = false;
1469
1470             if (is_capped_double
1471                 && Nkind (gnat_prefix) == N_Identifier
1472                 && Present (Alignment_Clause (Entity (gnat_prefix))))
1473               align_clause = true;
1474
1475             if (is_capped_double && !align_clause)
1476               align = double_align;
1477             else
1478               align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1479           }
1480
1481         gnu_result = size_int (align);
1482       }
1483       break;
1484
1485     case Attr_First:
1486     case Attr_Last:
1487     case Attr_Range_Length:
1488       prefix_unused = true;
1489
1490       if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1491         {
1492           gnu_result_type = get_unpadded_type (Etype (gnat_node));
1493
1494           if (attribute == Attr_First)
1495             gnu_result = TYPE_MIN_VALUE (gnu_type);
1496           else if (attribute == Attr_Last)
1497             gnu_result = TYPE_MAX_VALUE (gnu_type);
1498           else
1499             gnu_result
1500               = build_binary_op
1501                 (MAX_EXPR, get_base_type (gnu_result_type),
1502                  build_binary_op
1503                  (PLUS_EXPR, get_base_type (gnu_result_type),
1504                   build_binary_op (MINUS_EXPR,
1505                                    get_base_type (gnu_result_type),
1506                                    convert (gnu_result_type,
1507                                             TYPE_MAX_VALUE (gnu_type)),
1508                                    convert (gnu_result_type,
1509                                             TYPE_MIN_VALUE (gnu_type))),
1510                   convert (gnu_result_type, integer_one_node)),
1511                  convert (gnu_result_type, integer_zero_node));
1512
1513           break;
1514         }
1515
1516       /* ... fall through ... */
1517
1518     case Attr_Length:
1519       {
1520         int Dimension = (Present (Expressions (gnat_node))
1521                          ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1522                          : 1), i;
1523         struct parm_attr_d *pa = NULL;
1524         Entity_Id gnat_param = Empty;
1525
1526         /* Make sure any implicit dereference gets done.  */
1527         gnu_prefix = maybe_implicit_deref (gnu_prefix);
1528         gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1529         /* We treat unconstrained array In parameters specially.  */
1530         if (Nkind (Prefix (gnat_node)) == N_Identifier
1531             && !Is_Constrained (Etype (Prefix (gnat_node)))
1532             && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1533           gnat_param = Entity (Prefix (gnat_node));
1534         gnu_type = TREE_TYPE (gnu_prefix);
1535         prefix_unused = true;
1536         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1537
1538         if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1539           {
1540             int ndim;
1541             tree gnu_type_temp;
1542
1543             for (ndim = 1, gnu_type_temp = gnu_type;
1544                  TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1545                  && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1546                  ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1547               ;
1548
1549             Dimension = ndim + 1 - Dimension;
1550           }
1551
1552         for (i = 1; i < Dimension; i++)
1553           gnu_type = TREE_TYPE (gnu_type);
1554
1555         gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1556
1557         /* When not optimizing, look up the slot associated with the parameter
1558            and the dimension in the cache and create a new one on failure.  */
1559         if (!optimize && Present (gnat_param))
1560           {
1561             for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
1562               if (pa->id == gnat_param && pa->dim == Dimension)
1563                 break;
1564
1565             if (!pa)
1566               {
1567                 pa = GGC_CNEW (struct parm_attr_d);
1568                 pa->id = gnat_param;
1569                 pa->dim = Dimension;
1570                 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1571               }
1572           }
1573
1574         /* Return the cached expression or build a new one.  */
1575         if (attribute == Attr_First)
1576           {
1577             if (pa && pa->first)
1578               {
1579                 gnu_result = pa->first;
1580                 break;
1581               }
1582
1583             gnu_result
1584               = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1585           }
1586
1587         else if (attribute == Attr_Last)
1588           {
1589             if (pa && pa->last)
1590               {
1591                 gnu_result = pa->last;
1592                 break;
1593               }
1594
1595             gnu_result
1596               = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1597           }
1598
1599         else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
1600           {
1601             if (pa && pa->length)
1602               {
1603                 gnu_result = pa->length;
1604                 break;
1605               }
1606             else
1607               {
1608                 /* We used to compute the length as max (hb - lb + 1, 0),
1609                    which could overflow for some cases of empty arrays, e.g.
1610                    when lb == index_type'first.  We now compute the length as
1611                    (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1612                    much rarer cases, for extremely large arrays we expect
1613                    never to encounter in practice.  In addition, the former
1614                    computation required the use of potentially constraining
1615                    signed arithmetic while the latter doesn't.  Note that
1616                    the comparison must be done in the original index type,
1617                    to avoid any overflow during the conversion.  */
1618                 tree comp_type = get_base_type (gnu_result_type);
1619                 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1620                 tree lb = TYPE_MIN_VALUE (index_type);
1621                 tree hb = TYPE_MAX_VALUE (index_type);
1622                 gnu_result
1623                   = build_binary_op (PLUS_EXPR, comp_type,
1624                                      build_binary_op (MINUS_EXPR,
1625                                                       comp_type,
1626                                                       convert (comp_type, hb),
1627                                                       convert (comp_type, lb)),
1628                                      convert (comp_type, integer_one_node));
1629                 gnu_result
1630                   = build_cond_expr (comp_type,
1631                                      build_binary_op (GE_EXPR,
1632                                                       integer_type_node,
1633                                                       hb, lb),
1634                                      gnu_result,
1635                                      convert (comp_type, integer_zero_node));
1636               }
1637           }
1638
1639         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1640            handling.  Note that these attributes could not have been used on
1641            an unconstrained array type.  */
1642         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1643
1644         /* Cache the expression we have just computed.  Since we want to do it
1645            at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1646            create the temporary.  */
1647         if (pa)
1648           {
1649             gnu_result
1650               = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1651             TREE_SIDE_EFFECTS (gnu_result) = 1;
1652             if (attribute == Attr_First)
1653               pa->first = gnu_result;
1654             else if (attribute == Attr_Last)
1655               pa->last = gnu_result;
1656             else
1657               pa->length = gnu_result;
1658           }
1659
1660         /* Set the source location onto the predicate of the condition in the
1661            'Length case but do not do it if the expression is cached to avoid
1662            messing up the debug info.  */
1663         else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1664                  && TREE_CODE (gnu_result) == COND_EXPR
1665                  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1666           set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1667                                        gnat_node);
1668
1669         break;
1670       }
1671
1672     case Attr_Bit_Position:
1673     case Attr_Position:
1674     case Attr_First_Bit:
1675     case Attr_Last_Bit:
1676     case Attr_Bit:
1677       {
1678         HOST_WIDE_INT bitsize;
1679         HOST_WIDE_INT bitpos;
1680         tree gnu_offset;
1681         tree gnu_field_bitpos;
1682         tree gnu_field_offset;
1683         tree gnu_inner;
1684         enum machine_mode mode;
1685         int unsignedp, volatilep;
1686
1687         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1688         gnu_prefix = remove_conversions (gnu_prefix, true);
1689         prefix_unused = true;
1690
1691         /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1692            the result is 0.  Don't allow 'Bit on a bare component, though.  */
1693         if (attribute == Attr_Bit
1694             && TREE_CODE (gnu_prefix) != COMPONENT_REF
1695             && TREE_CODE (gnu_prefix) != FIELD_DECL)
1696           {
1697             gnu_result = integer_zero_node;
1698             break;
1699           }
1700
1701         else
1702           gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1703                       || (attribute == Attr_Bit_Position
1704                           && TREE_CODE (gnu_prefix) == FIELD_DECL));
1705
1706         get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1707                              &mode, &unsignedp, &volatilep, false);
1708
1709         if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1710           {
1711             gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1712             gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1713
1714             for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1715                  TREE_CODE (gnu_inner) == COMPONENT_REF
1716                  && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1717                  gnu_inner = TREE_OPERAND (gnu_inner, 0))
1718               {
1719                 gnu_field_bitpos
1720                   = size_binop (PLUS_EXPR, gnu_field_bitpos,
1721                                 bit_position (TREE_OPERAND (gnu_inner, 1)));
1722                 gnu_field_offset
1723                   = size_binop (PLUS_EXPR, gnu_field_offset,
1724                                 byte_position (TREE_OPERAND (gnu_inner, 1)));
1725               }
1726           }
1727         else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1728           {
1729             gnu_field_bitpos = bit_position (gnu_prefix);
1730             gnu_field_offset = byte_position (gnu_prefix);
1731           }
1732         else
1733           {
1734             gnu_field_bitpos = bitsize_zero_node;
1735             gnu_field_offset = size_zero_node;
1736           }
1737
1738         switch (attribute)
1739           {
1740           case Attr_Position:
1741             gnu_result = gnu_field_offset;
1742             break;
1743
1744           case Attr_First_Bit:
1745           case Attr_Bit:
1746             gnu_result = size_int (bitpos % BITS_PER_UNIT);
1747             break;
1748
1749           case Attr_Last_Bit:
1750             gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1751             gnu_result = size_binop (PLUS_EXPR, gnu_result,
1752                                      TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1753             gnu_result = size_binop (MINUS_EXPR, gnu_result,
1754                                      bitsize_one_node);
1755             break;
1756
1757           case Attr_Bit_Position:
1758             gnu_result = gnu_field_bitpos;
1759             break;
1760                 }
1761
1762         /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1763            handling.  */
1764         gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1765         break;
1766       }
1767
1768     case Attr_Min:
1769     case Attr_Max:
1770       {
1771         tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1772         tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1773
1774         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1775         gnu_result = build_binary_op (attribute == Attr_Min
1776                                       ? MIN_EXPR : MAX_EXPR,
1777                                       gnu_result_type, gnu_lhs, gnu_rhs);
1778       }
1779       break;
1780
1781     case Attr_Passed_By_Reference:
1782       gnu_result = size_int (default_pass_by_ref (gnu_type)
1783                              || must_pass_by_ref (gnu_type));
1784       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1785       break;
1786
1787     case Attr_Component_Size:
1788       if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1789           && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1790         gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1791
1792       gnu_prefix = maybe_implicit_deref (gnu_prefix);
1793       gnu_type = TREE_TYPE (gnu_prefix);
1794
1795       if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1796         gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1797
1798       while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1799              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1800         gnu_type = TREE_TYPE (gnu_type);
1801
1802       gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1803
1804       /* Note this size cannot be self-referential.  */
1805       gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1806       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1807       prefix_unused = true;
1808       break;
1809
1810     case Attr_Null_Parameter:
1811       /* This is just a zero cast to the pointer type for our prefix and
1812          dereferenced.  */
1813       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1814       gnu_result
1815         = build_unary_op (INDIRECT_REF, NULL_TREE,
1816                           convert (build_pointer_type (gnu_result_type),
1817                                    integer_zero_node));
1818       TREE_PRIVATE (gnu_result) = 1;
1819       break;
1820
1821     case Attr_Mechanism_Code:
1822       {
1823         int code;
1824         Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1825
1826         prefix_unused = true;
1827         gnu_result_type = get_unpadded_type (Etype (gnat_node));
1828         if (Present (Expressions (gnat_node)))
1829           {
1830             int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1831
1832             for (gnat_obj = First_Formal (gnat_obj); i > 1;
1833                  i--, gnat_obj = Next_Formal (gnat_obj))
1834               ;
1835           }
1836
1837         code = Mechanism (gnat_obj);
1838         if (code == Default)
1839           code = ((present_gnu_tree (gnat_obj)
1840                    && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1841                        || ((TREE_CODE (get_gnu_tree (gnat_obj))
1842                             == PARM_DECL)
1843                            && (DECL_BY_COMPONENT_PTR_P
1844                                (get_gnu_tree (gnat_obj))))))
1845                   ? By_Reference : By_Copy);
1846         gnu_result = convert (gnu_result_type, size_int (- code));
1847       }
1848       break;
1849
1850     default:
1851       /* Say we have an unimplemented attribute.  Then set the value to be
1852          returned to be a zero and hope that's something we can convert to
1853          the type of this attribute.  */
1854       post_error ("unimplemented attribute", gnat_node);
1855       gnu_result_type = get_unpadded_type (Etype (gnat_node));
1856       gnu_result = integer_zero_node;
1857       break;
1858     }
1859
1860   /* If this is an attribute where the prefix was unused, force a use of it if
1861      it has a side-effect.  But don't do it if the prefix is just an entity
1862      name.  However, if an access check is needed, we must do it.  See second
1863      example in AARM 11.6(5.e).  */
1864   if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1865       && !Is_Entity_Name (Prefix (gnat_node)))
1866     gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1867                               gnu_prefix, gnu_result);
1868
1869   *gnu_result_type_p = gnu_result_type;
1870   return gnu_result;
1871 }
1872 \f
1873 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1874    to a GCC tree, which is returned.  */
1875
1876 static tree
1877 Case_Statement_to_gnu (Node_Id gnat_node)
1878 {
1879   tree gnu_result;
1880   tree gnu_expr;
1881   Node_Id gnat_when;
1882
1883   gnu_expr = gnat_to_gnu (Expression (gnat_node));
1884   gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1885
1886   /*  The range of values in a case statement is determined by the rules in
1887       RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1888       of the expression. One exception arises in the case of a simple name that
1889       is parenthesized. This still has the Etype of the name, but since it is
1890       not a name, para 7 does not apply, and we need to go to the base type.
1891       This is the only case where parenthesization affects the dynamic
1892       semantics (i.e. the range of possible values at runtime that is covered
1893       by the others alternative.
1894
1895       Another exception is if the subtype of the expression is non-static.  In
1896       that case, we also have to use the base type.  */
1897   if (Paren_Count (Expression (gnat_node)) != 0
1898       || !Is_OK_Static_Subtype (Underlying_Type
1899                                 (Etype (Expression (gnat_node)))))
1900     gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1901
1902   /* We build a SWITCH_EXPR that contains the code with interspersed
1903      CASE_LABEL_EXPRs for each label.  */
1904
1905   push_stack (&gnu_switch_label_stack, NULL_TREE,
1906               create_artificial_label (input_location));
1907   start_stmt_group ();
1908   for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1909        Present (gnat_when);
1910        gnat_when = Next_Non_Pragma (gnat_when))
1911     {
1912       bool choices_added_p = false;
1913       Node_Id gnat_choice;
1914
1915       /* First compile all the different case choices for the current WHEN
1916          alternative.  */
1917       for (gnat_choice = First (Discrete_Choices (gnat_when));
1918            Present (gnat_choice); gnat_choice = Next (gnat_choice))
1919         {
1920           tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1921
1922           switch (Nkind (gnat_choice))
1923             {
1924             case N_Range:
1925               gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1926               gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1927               break;
1928
1929             case N_Subtype_Indication:
1930               gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1931                                                 (Constraint (gnat_choice))));
1932               gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1933                                                   (Constraint (gnat_choice))));
1934               break;
1935
1936             case N_Identifier:
1937             case N_Expanded_Name:
1938               /* This represents either a subtype range or a static value of
1939                  some kind; Ekind says which.  */
1940               if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1941                 {
1942                   tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1943
1944                   gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1945                   gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1946                   break;
1947                 }
1948
1949               /* ... fall through ... */
1950
1951             case N_Character_Literal:
1952             case N_Integer_Literal:
1953               gnu_low = gnat_to_gnu (gnat_choice);
1954               break;
1955
1956             case N_Others_Choice:
1957               break;
1958
1959             default:
1960               gcc_unreachable ();
1961             }
1962
1963           /* If the case value is a subtype that raises Constraint_Error at
1964              run-time because of a wrong bound, then gnu_low or gnu_high is
1965              not translated into an INTEGER_CST.  In such a case, we need
1966              to ensure that the when statement is not added in the tree,
1967              otherwise it will crash the gimplifier.  */
1968           if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
1969               && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
1970             {
1971               add_stmt_with_node (build3
1972                                   (CASE_LABEL_EXPR, void_type_node,
1973                                    gnu_low, gnu_high,
1974                                    create_artificial_label (input_location)),
1975                                   gnat_choice);
1976               choices_added_p = true;
1977             }
1978         }
1979
1980       /* Push a binding level here in case variables are declared as we want
1981          them to be local to this set of statements instead of to the block
1982          containing the Case statement.  */
1983       if (choices_added_p)
1984         {
1985           add_stmt (build_stmt_group (Statements (gnat_when), true));
1986           add_stmt (build1 (GOTO_EXPR, void_type_node,
1987                             TREE_VALUE (gnu_switch_label_stack)));
1988         }
1989     }
1990
1991   /* Now emit a definition of the label all the cases branched to.  */
1992   add_stmt (build1 (LABEL_EXPR, void_type_node,
1993                     TREE_VALUE (gnu_switch_label_stack)));
1994   gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
1995                        end_stmt_group (), NULL_TREE);
1996   pop_stack (&gnu_switch_label_stack);
1997
1998   return gnu_result;
1999 }
2000 \f
2001 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2002    to a GCC tree, which is returned.  */
2003
2004 static tree
2005 Loop_Statement_to_gnu (Node_Id gnat_node)
2006 {
2007   /* ??? It would be nice to use "build" here, but there's no build5.  */
2008   tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
2009                                  NULL_TREE, NULL_TREE, NULL_TREE);
2010   tree gnu_loop_var = NULL_TREE;
2011   Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2012   tree gnu_cond_expr = NULL_TREE;
2013   tree gnu_result;
2014
2015   TREE_TYPE (gnu_loop_stmt) = void_type_node;
2016   TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2017   LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (input_location);
2018   set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2019   Sloc_to_locus (Sloc (End_Label (gnat_node)),
2020                  &DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt)));
2021
2022   /* Save the end label of this LOOP_STMT in a stack so that the corresponding
2023      N_Exit_Statement can find it.  */
2024   push_stack (&gnu_loop_label_stack, NULL_TREE,
2025               LOOP_STMT_LABEL (gnu_loop_stmt));
2026
2027   /* Set the condition under which the loop must keep going.
2028      For the case "LOOP .... END LOOP;" the condition is always true.  */
2029   if (No (gnat_iter_scheme))
2030     ;
2031
2032   /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate.  */
2033   else if (Present (Condition (gnat_iter_scheme)))
2034     LOOP_STMT_TOP_COND (gnu_loop_stmt)
2035       = gnat_to_gnu (Condition (gnat_iter_scheme));
2036
2037   /* Otherwise we have an iteration scheme and the condition is given by
2038      the bounds of the subtype of the iteration variable.  */
2039   else
2040     {
2041       Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2042       Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2043       Entity_Id gnat_type = Etype (gnat_loop_var);
2044       tree gnu_type = get_unpadded_type (gnat_type);
2045       tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2046       tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2047       tree gnu_first, gnu_last, gnu_limit;
2048       enum tree_code update_code, end_code;
2049       tree gnu_base_type = get_base_type (gnu_type);
2050
2051       /* We must disable modulo reduction for the loop variable, if any,
2052          in order for the loop comparison to be effective.  */
2053       if (Reverse_Present (gnat_loop_spec))
2054         {
2055           gnu_first = gnu_high;
2056           gnu_last = gnu_low;
2057           update_code = MINUS_NOMOD_EXPR;
2058           end_code = GE_EXPR;
2059           gnu_limit = TYPE_MIN_VALUE (gnu_base_type);
2060         }
2061       else
2062         {
2063           gnu_first = gnu_low;
2064           gnu_last = gnu_high;
2065           update_code = PLUS_NOMOD_EXPR;
2066           end_code = LE_EXPR;
2067           gnu_limit = TYPE_MAX_VALUE (gnu_base_type);
2068         }
2069
2070       /* We know the loop variable will not overflow if GNU_LAST is a constant
2071          and is not equal to GNU_LIMIT.  If it might overflow, we have to move
2072          the limit test to the end of the loop.  In that case, we have to test
2073          for an empty loop outside the loop.  */
2074       if (TREE_CODE (gnu_last) != INTEGER_CST
2075           || TREE_CODE (gnu_limit) != INTEGER_CST
2076           || tree_int_cst_equal (gnu_last, gnu_limit))
2077         {
2078           gnu_cond_expr
2079             = build3 (COND_EXPR, void_type_node,
2080                       build_binary_op (LE_EXPR, integer_type_node,
2081                                        gnu_low, gnu_high),
2082                       NULL_TREE, alloc_stmt_list ());
2083           set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2084         }
2085
2086       /* Open a new nesting level that will surround the loop to declare the
2087          loop index variable.  */
2088       start_stmt_group ();
2089       gnat_pushlevel ();
2090
2091       /* Declare the loop index and set it to its initial value.  */
2092       gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2093       if (DECL_BY_REF_P (gnu_loop_var))
2094         gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2095
2096       /* The loop variable might be a padded type, so use `convert' to get a
2097          reference to the inner variable if so.  */
2098       gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
2099
2100       /* Set either the top or bottom exit condition as appropriate depending
2101          on whether or not we know an overflow cannot occur.  */
2102       if (gnu_cond_expr)
2103         LOOP_STMT_BOT_COND (gnu_loop_stmt)
2104           = build_binary_op (NE_EXPR, integer_type_node,
2105                              gnu_loop_var, gnu_last);
2106       else
2107         LOOP_STMT_TOP_COND (gnu_loop_stmt)
2108           = build_binary_op (end_code, integer_type_node,
2109                              gnu_loop_var, gnu_last);
2110
2111       LOOP_STMT_UPDATE (gnu_loop_stmt)
2112         = build_binary_op (MODIFY_EXPR, NULL_TREE,
2113                            gnu_loop_var,
2114                            build_binary_op (update_code,
2115                                             TREE_TYPE (gnu_loop_var),
2116                                             gnu_loop_var,
2117                                             convert (TREE_TYPE (gnu_loop_var),
2118                                                      integer_one_node)));
2119       set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
2120                                    gnat_iter_scheme);
2121     }
2122
2123   /* If the loop was named, have the name point to this loop.  In this case,
2124      the association is not a ..._DECL node, but the end label from this
2125      LOOP_STMT.  */
2126   if (Present (Identifier (gnat_node)))
2127     save_gnu_tree (Entity (Identifier (gnat_node)),
2128                    LOOP_STMT_LABEL (gnu_loop_stmt), true);
2129
2130   /* Make the loop body into its own block, so any allocated storage will be
2131      released every iteration.  This is needed for stack allocation.  */
2132   LOOP_STMT_BODY (gnu_loop_stmt)
2133     = build_stmt_group (Statements (gnat_node), true);
2134
2135   /* If we declared a variable, then we are in a statement group for that
2136      declaration.  Add the LOOP_STMT to it and make that the "loop".  */
2137   if (gnu_loop_var)
2138     {
2139       add_stmt (gnu_loop_stmt);
2140       gnat_poplevel ();
2141       gnu_loop_stmt = end_stmt_group ();
2142     }
2143
2144   /* If we have an outer COND_EXPR, that's our result and this loop is its
2145      "true" statement.  Otherwise, the result is the LOOP_STMT.  */
2146   if (gnu_cond_expr)
2147     {
2148       COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2149       gnu_result = gnu_cond_expr;
2150       recalculate_side_effects (gnu_cond_expr);
2151     }
2152   else
2153     gnu_result = gnu_loop_stmt;
2154
2155   pop_stack (&gnu_loop_label_stack);
2156
2157   return gnu_result;
2158 }
2159 \f
2160 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2161    handler for the current function.  */
2162
2163 /* This is implemented by issuing a call to the appropriate VMS specific
2164    builtin.  To avoid having VMS specific sections in the global gigi decls
2165    array, we maintain the decls of interest here.  We can't declare them
2166    inside the function because we must mark them never to be GC'd, which we
2167    can only do at the global level.  */
2168
2169 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2170 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2171
2172 static void
2173 establish_gnat_vms_condition_handler (void)
2174 {
2175   tree establish_stmt;
2176
2177   /* Elaborate the required decls on the first call.  Check on the decl for
2178      the gnat condition handler to decide, as this is one we create so we are
2179      sure that it will be non null on subsequent calls.  The builtin decl is
2180      looked up so remains null on targets where it is not implemented yet.  */
2181   if (gnat_vms_condition_handler_decl == NULL_TREE)
2182     {
2183       vms_builtin_establish_handler_decl
2184         = builtin_decl_for
2185           (get_identifier ("__builtin_establish_vms_condition_handler"));
2186
2187       gnat_vms_condition_handler_decl
2188         = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2189                                NULL_TREE,
2190                                build_function_type_list (integer_type_node,
2191                                                          ptr_void_type_node,
2192                                                          ptr_void_type_node,
2193                                                          NULL_TREE),
2194                                NULL_TREE, 0, 1, 1, 0, Empty);
2195
2196       /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL.  */
2197       DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2198     }
2199
2200   /* Do nothing if the establish builtin is not available, which might happen
2201      on targets where the facility is not implemented.  */
2202   if (vms_builtin_establish_handler_decl == NULL_TREE)
2203     return;
2204
2205   establish_stmt
2206     = build_call_1_expr (vms_builtin_establish_handler_decl,
2207                          build_unary_op
2208                          (ADDR_EXPR, NULL_TREE,
2209                           gnat_vms_condition_handler_decl));
2210
2211   add_stmt (establish_stmt);
2212 }
2213 \f
2214 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
2215    don't return anything.  */
2216
2217 static void
2218 Subprogram_Body_to_gnu (Node_Id gnat_node)
2219 {
2220   /* Defining identifier of a parameter to the subprogram.  */
2221   Entity_Id gnat_param;
2222   /* The defining identifier for the subprogram body. Note that if a
2223      specification has appeared before for this body, then the identifier
2224      occurring in that specification will also be a defining identifier and all
2225      the calls to this subprogram will point to that specification.  */
2226   Entity_Id gnat_subprog_id
2227     = (Present (Corresponding_Spec (gnat_node))
2228        ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2229   /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
2230   tree gnu_subprog_decl;
2231   /* Its RESULT_DECL node.  */
2232   tree gnu_result_decl;
2233   /* The FUNCTION_TYPE node corresponding to the subprogram spec.  */
2234   tree gnu_subprog_type;
2235   tree gnu_cico_list;
2236   tree gnu_result;
2237   VEC(parm_attr,gc) *cache;
2238
2239   /* If this is a generic object or if it has been eliminated,
2240      ignore it.  */
2241   if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2242       || Ekind (gnat_subprog_id) == E_Generic_Function
2243       || Is_Eliminated (gnat_subprog_id))
2244     return;
2245
2246   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
2247      the already-elaborated tree node.  However, if this subprogram had its
2248      elaboration deferred, we will already have made a tree node for it.  So
2249      treat it as not being defined in that case.  Such a subprogram cannot
2250      have an address clause or a freeze node, so this test is safe, though it
2251      does disable some otherwise-useful error checking.  */
2252   gnu_subprog_decl
2253     = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2254                           Acts_As_Spec (gnat_node)
2255                           && !present_gnu_tree (gnat_subprog_id));
2256   gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
2257   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2258
2259   /* If the function returns by invisible reference, make it explicit in the
2260      function body.  See gnat_to_gnu_entity, E_Subprogram_Type case.  */
2261   if (TREE_ADDRESSABLE (gnu_subprog_type))
2262     {
2263       TREE_TYPE (gnu_result_decl)
2264         = build_reference_type (TREE_TYPE (gnu_result_decl));
2265       relayout_decl (gnu_result_decl);
2266     }
2267
2268   /* Propagate the debug mode.  */
2269   if (!Needs_Debug_Info (gnat_subprog_id))
2270     DECL_IGNORED_P (gnu_subprog_decl) = 1;
2271
2272   /* Set the line number in the decl to correspond to that of the body so that
2273      the line number notes are written correctly.  */
2274   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
2275
2276   /* Initialize the information structure for the function.  */
2277   allocate_struct_function (gnu_subprog_decl, false);
2278   DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
2279     = GGC_CNEW (struct language_function);
2280
2281   begin_subprog_body (gnu_subprog_decl);
2282   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2283
2284   /* If there are Out parameters, we need to ensure that the return statement
2285      properly copies them out.  We do this by making a new block and converting
2286      any inner return into a goto to a label at the end of the block.  */
2287   push_stack (&gnu_return_label_stack, NULL_TREE,
2288               gnu_cico_list ? create_artificial_label (input_location)
2289               : NULL_TREE);
2290
2291   /* Get a tree corresponding to the code for the subprogram.  */
2292   start_stmt_group ();
2293   gnat_pushlevel ();
2294
2295   /* See if there are any parameters for which we don't yet have GCC entities.
2296      These must be for Out parameters for which we will be making VAR_DECL
2297      nodes here.  Fill them in to TYPE_CI_CO_LIST, which must contain the empty
2298      entry as well.  We can match up the entries because TYPE_CI_CO_LIST is in
2299      the order of the parameters.  */
2300   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2301        Present (gnat_param);
2302        gnat_param = Next_Formal_With_Extras (gnat_param))
2303     if (!present_gnu_tree (gnat_param))
2304       {
2305         /* Skip any entries that have been already filled in; they must
2306            correspond to In Out parameters.  */
2307         for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
2308              gnu_cico_list = TREE_CHAIN (gnu_cico_list))
2309           ;
2310
2311         /* Do any needed references for padded types.  */
2312         TREE_VALUE (gnu_cico_list)
2313           = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
2314                      gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2315       }
2316
2317   /* On VMS, establish our condition handler to possibly turn a condition into
2318      the corresponding exception if the subprogram has a foreign convention or
2319      is exported.
2320
2321      To ensure proper execution of local finalizations on condition instances,
2322      we must turn a condition into the corresponding exception even if there
2323      is no applicable Ada handler, and need at least one condition handler per
2324      possible call chain involving GNAT code.  OTOH, establishing the handler
2325      has a cost so we want to minimize the number of subprograms into which
2326      this happens.  The foreign or exported condition is expected to satisfy
2327      all the constraints.  */
2328   if (TARGET_ABI_OPEN_VMS
2329       && (Has_Foreign_Convention (gnat_subprog_id)
2330           || Is_Exported (gnat_subprog_id)))
2331     establish_gnat_vms_condition_handler ();
2332
2333   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
2334
2335   /* Generate the code of the subprogram itself.  A return statement will be
2336      present and any Out parameters will be handled there.  */
2337   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
2338   gnat_poplevel ();
2339   gnu_result = end_stmt_group ();
2340
2341   /* If we populated the parameter attributes cache, we need to make sure
2342      that the cached expressions are evaluated on all possible paths.  */
2343   cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
2344   if (cache)
2345     {
2346       struct parm_attr_d *pa;
2347       int i;
2348
2349       start_stmt_group ();
2350
2351       for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
2352         {
2353           if (pa->first)
2354             add_stmt_with_node (pa->first, gnat_node);
2355           if (pa->last)
2356             add_stmt_with_node (pa->last, gnat_node);
2357           if (pa->length)
2358             add_stmt_with_node (pa->length, gnat_node);
2359         }
2360
2361       add_stmt (gnu_result);
2362       gnu_result = end_stmt_group ();
2363     }
2364
2365     /* If we are dealing with a return from an Ada procedure with parameters
2366        passed by copy-in/copy-out, we need to return a record containing the
2367        final values of these parameters.  If the list contains only one entry,
2368        return just that entry though.
2369
2370        For a full description of the copy-in/copy-out parameter mechanism, see
2371        the part of the gnat_to_gnu_entity routine dealing with the translation
2372        of subprograms.
2373
2374        We need to make a block that contains the definition of that label and
2375        the copying of the return value.  It first contains the function, then
2376        the label and copy statement.  */
2377   if (TREE_VALUE (gnu_return_label_stack))
2378     {
2379       tree gnu_retval;
2380
2381       start_stmt_group ();
2382       gnat_pushlevel ();
2383       add_stmt (gnu_result);
2384       add_stmt (build1 (LABEL_EXPR, void_type_node,
2385                         TREE_VALUE (gnu_return_label_stack)));
2386
2387       gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2388       if (list_length (gnu_cico_list) == 1)
2389         gnu_retval = TREE_VALUE (gnu_cico_list);
2390       else
2391         gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2392                                              gnu_cico_list);
2393
2394       add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
2395                           End_Label (Handled_Statement_Sequence (gnat_node)));
2396       gnat_poplevel ();
2397       gnu_result = end_stmt_group ();
2398     }
2399
2400   pop_stack (&gnu_return_label_stack);
2401
2402   /* Set the end location.  */
2403   Sloc_to_locus
2404     ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
2405       ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
2406       : Sloc (gnat_node)),
2407      &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
2408
2409   end_subprog_body (gnu_result);
2410
2411   /* Finally annotate the parameters and disconnect the trees for parameters
2412      that we have turned into variables since they are now unusable.  */
2413   for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2414        Present (gnat_param);
2415        gnat_param = Next_Formal_With_Extras (gnat_param))
2416     {
2417       tree gnu_param = get_gnu_tree (gnat_param);
2418       annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
2419                        DECL_BY_REF_P (gnu_param));
2420       if (TREE_CODE (gnu_param) == VAR_DECL)
2421         save_gnu_tree (gnat_param, NULL_TREE, false);
2422     }
2423
2424   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2425     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2426
2427   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2428 }
2429 \f
2430 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2431    or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2432    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2433    If GNU_TARGET is non-null, this must be a function call and the result
2434    of the call is to be placed into that object.  */
2435
2436 static tree
2437 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2438 {
2439   /* The GCC node corresponding to the GNAT subprogram name.  This can either
2440      be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2441      or an indirect reference expression (an INDIRECT_REF node) pointing to a
2442      subprogram.  */
2443   tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
2444   /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
2445   tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
2446   tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
2447   Entity_Id gnat_formal;
2448   Node_Id gnat_actual;
2449   tree gnu_actual_list = NULL_TREE;
2450   tree gnu_name_list = NULL_TREE;
2451   tree gnu_before_list = NULL_TREE;
2452   tree gnu_after_list = NULL_TREE;
2453   tree gnu_call;
2454
2455   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2456
2457   /* If we are calling a stubbed function, raise Program_Error, but Elaborate
2458      all our args first.  */
2459   if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
2460     {
2461       tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
2462                                          gnat_node, N_Raise_Program_Error);
2463
2464       for (gnat_actual = First_Actual (gnat_node);
2465            Present (gnat_actual);
2466            gnat_actual = Next_Actual (gnat_actual))
2467         add_stmt (gnat_to_gnu (gnat_actual));
2468
2469       if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
2470         {
2471           *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
2472           return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr);
2473         }
2474
2475       return call_expr;
2476     }
2477
2478   /* The only way we can be making a call via an access type is if Name is an
2479      explicit dereference.  In that case, get the list of formal args from the
2480      type the access type is pointing to.  Otherwise, get the formals from the
2481      entity being called.  */
2482   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2483     gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2484   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2485     /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
2486     gnat_formal = Empty;
2487   else
2488     gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2489
2490   /* Create the list of the actual parameters as GCC expects it, namely a
2491      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
2492      is an expression and the TREE_PURPOSE field is null.  But skip Out
2493      parameters not passed by reference and that need not be copied in.  */
2494   for (gnat_actual = First_Actual (gnat_node);
2495        Present (gnat_actual);
2496        gnat_formal = Next_Formal_With_Extras (gnat_formal),
2497        gnat_actual = Next_Actual (gnat_actual))
2498     {
2499       tree gnu_formal = present_gnu_tree (gnat_formal)
2500                         ? get_gnu_tree (gnat_formal) : NULL_TREE;
2501       tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2502       /* In the Out or In Out case, we must suppress conversions that yield
2503          an lvalue but can nevertheless cause the creation of a temporary,
2504          because we need the real object in this case, either to pass its
2505          address if it's passed by reference or as target of the back copy
2506          done after the call if it uses the copy-in copy-out mechanism.
2507          We do it in the In case too, except for an unchecked conversion
2508          because it alone can cause the actual to be misaligned and the
2509          addressability test is applied to the real object.  */
2510       bool suppress_type_conversion
2511         = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2512             && Ekind (gnat_formal) != E_In_Parameter)
2513            || (Nkind (gnat_actual) == N_Type_Conversion
2514                && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2515       Node_Id gnat_name = suppress_type_conversion
2516                           ? Expression (gnat_actual) : gnat_actual;
2517       tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2518       tree gnu_actual;
2519
2520       /* If it's possible we may need to use this expression twice, make sure
2521          that any side-effects are handled via SAVE_EXPRs; likewise if we need
2522          to force side-effects before the call.
2523          ??? This is more conservative than we need since we don't need to do
2524          this for pass-by-ref with no conversion.  */
2525       if (Ekind (gnat_formal) != E_In_Parameter)
2526         gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
2527
2528       /* If we are passing a non-addressable parameter by reference, pass the
2529          address of a copy.  In the Out or In Out case, set up to copy back
2530          out after the call.  */
2531       if (gnu_formal
2532           && (DECL_BY_REF_P (gnu_formal)
2533               || (TREE_CODE (gnu_formal) == PARM_DECL
2534                   && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2535                       || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2536           && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2537           && !addressable_p (gnu_name, gnu_name_type))
2538         {
2539           tree gnu_copy = gnu_name;
2540
2541           /* If the type is passed by reference, a copy is not allowed.  */
2542           if (AGGREGATE_TYPE_P (gnu_formal_type)
2543               && TYPE_BY_REFERENCE_P (gnu_formal_type))
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
2614           = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
2615
2616       /* Put back the conversion we suppressed above in the computation of the
2617          real object.  And even if we didn't suppress any conversion there, we
2618          may have suppressed a conversion to the Etype of the actual earlier,
2619          since the parent is a procedure call, so put it back here.  */
2620       if (suppress_type_conversion
2621           && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2622         gnu_actual
2623           = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2624                                gnu_actual, No_Truncation (gnat_actual));
2625       else
2626         gnu_actual
2627           = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
2628
2629       /* Make sure that the actual is in range of the formal's type.  */
2630       if (Ekind (gnat_formal) != E_Out_Parameter
2631           && Do_Range_Check (gnat_actual))
2632         gnu_actual
2633           = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
2634
2635       /* And convert it to this type.  */
2636       if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2637         gnu_actual = convert (gnu_formal_type, gnu_actual);
2638
2639       /* Unless this is an In parameter, we must remove any justified modular
2640          building from GNU_NAME to get an lvalue.  */
2641       if (Ekind (gnat_formal) != E_In_Parameter
2642           && TREE_CODE (gnu_name) == CONSTRUCTOR
2643           && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2644           && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2645         gnu_name
2646           = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
2647
2648       /* If we have not saved a GCC object for the formal, it means it is an
2649          Out parameter not passed by reference and that need not be copied in.
2650          Otherwise, first see if the PARM_DECL is passed by reference.  */
2651       if (gnu_formal
2652           && TREE_CODE (gnu_formal) == PARM_DECL
2653           && DECL_BY_REF_P (gnu_formal))
2654         {
2655           if (Ekind (gnat_formal) != E_In_Parameter)
2656             {
2657               /* In Out or Out parameters passed by reference don't use the
2658                  copy-in copy-out mechanism so the address of the real object
2659                  must be passed to the function.  */
2660               gnu_actual = gnu_name;
2661
2662               /* If we have a padded type, be sure we've removed padding.  */
2663               if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
2664                   && TREE_CODE (gnu_actual) != SAVE_EXPR)
2665                 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2666                                       gnu_actual);
2667
2668               /* If we have the constructed subtype of an aliased object
2669                  with an unconstrained nominal subtype, the type of the
2670                  actual includes the template, although it is formally
2671                  constrained.  So we need to convert it back to the real
2672                  constructed subtype to retrieve the constrained part
2673                  and takes its address.  */
2674               if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2675                   && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
2676                   && TREE_CODE (gnu_actual) != SAVE_EXPR
2677                   && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
2678                   && Is_Array_Type (Etype (gnat_actual)))
2679                 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2680                                       gnu_actual);
2681             }
2682
2683           /* The symmetry of the paths to the type of an entity is broken here
2684              since arguments don't know that they will be passed by ref.  */
2685           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2686           gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2687         }
2688       else if (gnu_formal
2689                && TREE_CODE (gnu_formal) == PARM_DECL
2690                && DECL_BY_COMPONENT_PTR_P (gnu_formal))
2691         {
2692           gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2693           gnu_actual = maybe_implicit_deref (gnu_actual);
2694           gnu_actual = maybe_unconstrained_array (gnu_actual);
2695
2696           if (TYPE_IS_PADDING_P (gnu_formal_type))
2697             {
2698               gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2699               gnu_actual = convert (gnu_formal_type, gnu_actual);
2700             }
2701
2702           /* Take the address of the object and convert to the proper pointer
2703              type.  We'd like to actually compute the address of the beginning
2704              of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2705              possibility that the ARRAY_REF might return a constant and we'd be
2706              getting the wrong address.  Neither approach is exactly correct,
2707              but this is the most likely to work in all cases.  */
2708           gnu_actual = convert (gnu_formal_type,
2709                                 build_unary_op (ADDR_EXPR, NULL_TREE,
2710                                                 gnu_actual));
2711         }
2712       else if (gnu_formal
2713                && TREE_CODE (gnu_formal) == PARM_DECL
2714                && DECL_BY_DESCRIPTOR_P (gnu_formal))
2715         {
2716           /* If this is 'Null_Parameter, pass a zero descriptor.  */
2717           if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2718                || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2719               && TREE_PRIVATE (gnu_actual))
2720             gnu_actual
2721               = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
2722           else
2723             gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
2724                                          fill_vms_descriptor (gnu_actual,
2725                                                               gnat_formal,
2726                                                               gnat_actual));
2727         }
2728       else
2729         {
2730           tree gnu_size;
2731
2732           if (Ekind (gnat_formal) != E_In_Parameter)
2733             gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
2734
2735           if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
2736             continue;
2737
2738           /* If this is 'Null_Parameter, pass a zero even though we are
2739              dereferencing it.  */
2740           if (TREE_CODE (gnu_actual) == INDIRECT_REF
2741               && TREE_PRIVATE (gnu_actual)
2742               && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
2743               && TREE_CODE (gnu_size) == INTEGER_CST
2744               && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
2745             gnu_actual
2746               = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
2747                                    convert (gnat_type_for_size
2748                                             (TREE_INT_CST_LOW (gnu_size), 1),
2749                                             integer_zero_node),
2750                                    false);
2751           else
2752             gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
2753         }
2754
2755       gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
2756     }
2757
2758   gnu_call = build_call_list (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr,
2759                               nreverse (gnu_actual_list));
2760   set_expr_location_from_node (gnu_call, gnat_node);
2761
2762   /* If it's a function call, the result is the call expression unless a target
2763      is specified, in which case we copy the result into the target and return
2764      the assignment statement.  */
2765   if (Nkind (gnat_node) == N_Function_Call)
2766     {
2767       tree gnu_result = gnu_call;
2768       enum tree_code op_code;
2769
2770       /* If the function returns an unconstrained array or by direct reference,
2771          we have to dereference the pointer.  */
2772       if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
2773           || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
2774         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2775
2776       if (gnu_target)
2777         {
2778           /* ??? If the return type has non-constant size, then force the
2779              return slot optimization as we would not be able to generate
2780              a temporary.  That's what has been done historically.  */
2781           if (TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_subprog_type))))
2782             op_code = MODIFY_EXPR;
2783           else
2784             op_code = INIT_EXPR;
2785
2786           gnu_result
2787             = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result);
2788         }
2789       else
2790         *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
2791
2792       return gnu_result;
2793     }
2794
2795   /* If this is the case where the GNAT tree contains a procedure call but the
2796      Ada procedure has copy-in/copy-out parameters, then the special parameter
2797      passing mechanism must be used.  */
2798   if (TYPE_CI_CO_LIST (gnu_subprog_type))
2799     {
2800       /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
2801          in copy out parameters.  */
2802       tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2803       int length = list_length (scalar_return_list);
2804
2805       if (length > 1)
2806         {
2807           tree gnu_name;
2808
2809           /* The call sequence must contain one and only one call, even though
2810              the function is const or pure.  So force a SAVE_EXPR.  */
2811           gnu_call = build1 (SAVE_EXPR, TREE_TYPE (gnu_call), gnu_call);
2812           TREE_SIDE_EFFECTS (gnu_call) = 1;
2813           gnu_name_list = nreverse (gnu_name_list);
2814
2815           /* If any of the names had side-effects, ensure they are all
2816              evaluated before the call.  */
2817           for (gnu_name = gnu_name_list;
2818                gnu_name;
2819                gnu_name = TREE_CHAIN (gnu_name))
2820             if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
2821               append_to_statement_list (TREE_VALUE (gnu_name),
2822                                         &gnu_before_list);
2823         }
2824
2825       if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2826         gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2827       else
2828         gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2829
2830       for (gnat_actual = First_Actual (gnat_node);
2831            Present (gnat_actual);
2832            gnat_formal = Next_Formal_With_Extras (gnat_formal),
2833            gnat_actual = Next_Actual (gnat_actual))
2834         /* If we are dealing with a copy in copy out parameter, we must
2835            retrieve its value from the record returned in the call.  */
2836         if (!(present_gnu_tree (gnat_formal)
2837               && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2838               && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2839                   || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2840                       && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2841                            || (DECL_BY_DESCRIPTOR_P
2842                                (get_gnu_tree (gnat_formal))))))))
2843             && Ekind (gnat_formal) != E_In_Parameter)
2844           {
2845             /* Get the value to assign to this Out or In Out parameter.  It is
2846                either the result of the function if there is only a single such
2847                parameter or the appropriate field from the record returned.  */
2848             tree gnu_result
2849               = length == 1
2850                 ? gnu_call
2851                 : build_component_ref (gnu_call, NULL_TREE,
2852                                        TREE_PURPOSE (scalar_return_list),
2853                                        false);
2854
2855             /* If the actual is a conversion, get the inner expression, which
2856                will be the real destination, and convert the result to the
2857                type of the actual parameter.  */
2858             tree gnu_actual
2859               = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
2860
2861             /* If the result is a padded type, remove the padding.  */
2862             if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
2863               gnu_result
2864                 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
2865                            gnu_result);
2866
2867             /* If the actual is a type conversion, the real target object is
2868                denoted by the inner Expression and we need to convert the
2869                result to the associated type.
2870                We also need to convert our gnu assignment target to this type
2871                if the corresponding GNU_NAME was constructed from the GNAT
2872                conversion node and not from the inner Expression.  */
2873             if (Nkind (gnat_actual) == N_Type_Conversion)
2874               {
2875                 gnu_result
2876                   = convert_with_check
2877                     (Etype (Expression (gnat_actual)), gnu_result,
2878                      Do_Overflow_Check (gnat_actual),
2879                      Do_Range_Check (Expression (gnat_actual)),
2880                      Float_Truncate (gnat_actual), gnat_actual);
2881
2882                 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
2883                   gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
2884               }
2885
2886             /* Unchecked conversions as actuals for Out parameters are not
2887                allowed in user code because they are not variables, but do
2888                occur in front-end expansions.  The associated GNU_NAME is
2889                always obtained from the inner expression in such cases.  */
2890             else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2891               gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
2892                                               gnu_result,
2893                                               No_Truncation (gnat_actual));
2894             else
2895               {
2896                 if (Do_Range_Check (gnat_actual))
2897                   gnu_result
2898                     = emit_range_check (gnu_result, Etype (gnat_actual),
2899                                         gnat_actual);
2900
2901                 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2902                       && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
2903                   gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
2904               }
2905
2906             /* Undo wrapping of boolean rvalues.  */
2907             if (TREE_CODE (gnu_actual) == NE_EXPR
2908                 && TREE_CODE (get_base_type (TREE_TYPE (gnu_actual)))
2909                    == BOOLEAN_TYPE
2910                 && integer_zerop (TREE_OPERAND (gnu_actual, 1)))
2911               gnu_actual = TREE_OPERAND (gnu_actual, 0);
2912             gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2913                                           gnu_actual, gnu_result);
2914             set_expr_location_from_node (gnu_result, gnat_node);
2915             append_to_statement_list (gnu_result, &gnu_before_list);
2916             scalar_return_list = TREE_CHAIN (scalar_return_list);
2917             gnu_name_list = TREE_CHAIN (gnu_name_list);
2918           }
2919     }
2920   else
2921     append_to_statement_list (gnu_call, &gnu_before_list);
2922
2923   append_to_statement_list (gnu_after_list, &gnu_before_list);
2924
2925   return gnu_before_list;
2926 }
2927 \f
2928 /* Subroutine of gnat_to_gnu to translate gnat_node, an
2929    N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned.  */
2930
2931 static tree
2932 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
2933 {
2934   tree gnu_jmpsave_decl = NULL_TREE;
2935   tree gnu_jmpbuf_decl = NULL_TREE;
2936   /* If just annotating, ignore all EH and cleanups.  */
2937   bool gcc_zcx = (!type_annotate_only
2938                   && Present (Exception_Handlers (gnat_node))
2939                   && Exception_Mechanism == Back_End_Exceptions);
2940   bool setjmp_longjmp
2941     = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
2942        && Exception_Mechanism == Setjmp_Longjmp);
2943   bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
2944   bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
2945   tree gnu_inner_block; /* The statement(s) for the block itself.  */
2946   tree gnu_result;
2947   tree gnu_expr;
2948   Node_Id gnat_temp;
2949
2950   /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
2951      and we have our own SJLJ mechanism.  To call the GCC mechanism, we call
2952      add_cleanup, and when we leave the binding, end_stmt_group will create
2953      the TRY_FINALLY_EXPR.
2954
2955      ??? The region level calls down there have been specifically put in place
2956      for a ZCX context and currently the order in which things are emitted
2957      (region/handlers) is different from the SJLJ case. Instead of putting
2958      other calls with different conditions at other places for the SJLJ case,
2959      it seems cleaner to reorder things for the SJLJ case and generalize the
2960      condition to make it not ZCX specific.
2961
2962      If there are any exceptions or cleanup processing involved, we need an
2963      outer statement group (for Setjmp_Longjmp) and binding level.  */
2964   if (binding_for_block)
2965     {
2966       start_stmt_group ();
2967       gnat_pushlevel ();
2968     }
2969
2970   /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
2971      area for address of previous buffer.  Do this first since we need to have
2972      the setjmp buf known for any decls in this block.  */
2973   if (setjmp_longjmp)
2974     {
2975       gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
2976                                           NULL_TREE, jmpbuf_ptr_type,
2977                                           build_call_0_expr (get_jmpbuf_decl),
2978                                           false, false, false, false, NULL,
2979                                           gnat_node);
2980       DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
2981
2982       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
2983          because of the unstructured form of EH used by setjmp_longjmp, there
2984          might be forward edges going to __builtin_setjmp receivers on which
2985          it is uninitialized, although they will never be actually taken.  */
2986       TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
2987       gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
2988                                          NULL_TREE, jmpbuf_type,
2989                                          NULL_TREE, false, false, false, false,
2990                                          NULL, gnat_node);
2991       DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
2992
2993       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
2994
2995       /* When we exit this block, restore the saved value.  */
2996       add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
2997                    End_Label (gnat_node));
2998     }
2999
3000   /* If we are to call a function when exiting this block, add a cleanup
3001      to the binding level we made above.  Note that add_cleanup is FIFO
3002      so we must register this cleanup after the EH cleanup just above.  */
3003   if (at_end)
3004     add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
3005                  End_Label (gnat_node));
3006
3007   /* Now build the tree for the declarations and statements inside this block.
3008      If this is SJLJ, set our jmp_buf as the current buffer.  */
3009   start_stmt_group ();
3010
3011   if (setjmp_longjmp)
3012     add_stmt (build_call_1_expr (set_jmpbuf_decl,
3013                                  build_unary_op (ADDR_EXPR, NULL_TREE,
3014                                                  gnu_jmpbuf_decl)));
3015
3016   if (Present (First_Real_Statement (gnat_node)))
3017     process_decls (Statements (gnat_node), Empty,
3018                    First_Real_Statement (gnat_node), true, true);
3019
3020   /* Generate code for each statement in the block.  */
3021   for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3022                     ? First_Real_Statement (gnat_node)
3023                     : First (Statements (gnat_node)));
3024        Present (gnat_temp); gnat_temp = Next (gnat_temp))
3025     add_stmt (gnat_to_gnu (gnat_temp));
3026   gnu_inner_block = end_stmt_group ();
3027
3028   /* Now generate code for the two exception models, if either is relevant for
3029      this block.  */
3030   if (setjmp_longjmp)
3031     {
3032       tree *gnu_else_ptr = 0;
3033       tree gnu_handler;
3034
3035       /* Make a binding level for the exception handling declarations and code
3036          and set up gnu_except_ptr_stack for the handlers to use.  */
3037       start_stmt_group ();
3038       gnat_pushlevel ();
3039
3040       push_stack (&gnu_except_ptr_stack, NULL_TREE,
3041                   create_var_decl (get_identifier ("EXCEPT_PTR"),
3042                                    NULL_TREE,
3043                                    build_pointer_type (except_type_node),
3044                                    build_call_0_expr (get_excptr_decl), false,
3045                                    false, false, false, NULL, gnat_node));
3046
3047       /* Generate code for each handler. The N_Exception_Handler case does the
3048          real work and returns a COND_EXPR for each handler, which we chain
3049          together here.  */
3050       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3051            Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
3052         {
3053           gnu_expr = gnat_to_gnu (gnat_temp);
3054
3055           /* If this is the first one, set it as the outer one. Otherwise,
3056              point the "else" part of the previous handler to us. Then point
3057              to our "else" part.  */
3058           if (!gnu_else_ptr)
3059             add_stmt (gnu_expr);
3060           else
3061             *gnu_else_ptr = gnu_expr;
3062
3063           gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3064         }
3065
3066       /* If none of the exception handlers did anything, re-raise but do not
3067          defer abortion.  */
3068       gnu_expr = build_call_1_expr (raise_nodefer_decl,
3069                                     TREE_VALUE (gnu_except_ptr_stack));
3070       set_expr_location_from_node
3071         (gnu_expr,
3072          Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
3073
3074       if (gnu_else_ptr)
3075         *gnu_else_ptr = gnu_expr;
3076       else
3077         add_stmt (gnu_expr);
3078
3079       /* End the binding level dedicated to the exception handlers and get the
3080          whole statement group.  */
3081       pop_stack (&gnu_except_ptr_stack);
3082       gnat_poplevel ();
3083       gnu_handler = end_stmt_group ();
3084
3085       /* If the setjmp returns 1, we restore our incoming longjmp value and
3086          then check the handlers.  */
3087       start_stmt_group ();
3088       add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
3089                                              gnu_jmpsave_decl),
3090                           gnat_node);
3091       add_stmt (gnu_handler);
3092       gnu_handler = end_stmt_group ();
3093
3094       /* This block is now "if (setjmp) ... <handlers> else <block>".  */
3095       gnu_result = build3 (COND_EXPR, void_type_node,
3096                            (build_call_1_expr
3097                             (setjmp_decl,
3098                              build_unary_op (ADDR_EXPR, NULL_TREE,
3099