OSDN Git Service

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