OSDN Git Service

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