OSDN Git Service

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