* gcc-interface/trans.c (elaborate_all_entities_for_package): New
[official-gcc.git] / gcc / ada / gcc-interface / trans.c
blob5ee82ec6f92ab582080cf4d3354b9f0d11474b68
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
20 * *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
23 * *
24 ****************************************************************************/
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "target.h"
30 #include "function.h"
31 #include "bitmap.h"
32 #include "tree.h"
33 #include "gimple-expr.h"
34 #include "stringpool.h"
35 #include "cgraph.h"
36 #include "predict.h"
37 #include "diagnostic.h"
38 #include "alias.h"
39 #include "fold-const.h"
40 #include "stor-layout.h"
41 #include "stmt.h"
42 #include "varasm.h"
43 #include "output.h"
44 #include "libfuncs.h" /* For set_stack_check_libfunc. */
45 #include "tree-iterator.h"
46 #include "gimplify.h"
47 #include "opts.h"
48 #include "common/common-target.h"
50 #include "ada.h"
51 #include "adadecode.h"
52 #include "types.h"
53 #include "atree.h"
54 #include "namet.h"
55 #include "nlists.h"
56 #include "snames.h"
57 #include "stringt.h"
58 #include "uintp.h"
59 #include "urealp.h"
60 #include "fe.h"
61 #include "sinfo.h"
62 #include "einfo.h"
63 #include "gadaint.h"
64 #include "ada-tree.h"
65 #include "gigi.h"
67 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
68 for fear of running out of stack space. If we need more, we use xmalloc
69 instead. */
70 #define ALLOCA_THRESHOLD 1000
72 /* Pointers to front-end tables accessed through macros. */
73 struct Node *Nodes_Ptr;
74 struct Flags *Flags_Ptr;
75 Node_Id *Next_Node_Ptr;
76 Node_Id *Prev_Node_Ptr;
77 struct Elist_Header *Elists_Ptr;
78 struct Elmt_Item *Elmts_Ptr;
79 struct String_Entry *Strings_Ptr;
80 Char_Code *String_Chars_Ptr;
81 struct List_Header *List_Headers_Ptr;
83 /* Highest number in the front-end node table. */
84 int max_gnat_nodes;
86 /* Current node being treated, in case abort called. */
87 Node_Id error_gnat_node;
89 /* True when gigi is being called on an analyzed but unexpanded
90 tree, and the only purpose of the call is to properly annotate
91 types with representation information. */
92 bool type_annotate_only;
94 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
95 static vec<Node_Id> gnat_validate_uc_list;
97 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
98 of unconstrained array IN parameters to avoid emitting a great deal of
99 redundant instructions to recompute them each time. */
100 struct GTY (()) parm_attr_d {
101 int id; /* GTY doesn't like Entity_Id. */
102 int dim;
103 tree first;
104 tree last;
105 tree length;
108 typedef struct parm_attr_d *parm_attr;
111 struct GTY(()) language_function {
112 vec<parm_attr, va_gc> *parm_attr_cache;
113 bitmap named_ret_val;
114 vec<tree, va_gc> *other_ret_val;
115 int gnat_ret;
118 #define f_parm_attr_cache \
119 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
121 #define f_named_ret_val \
122 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
124 #define f_other_ret_val \
125 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
127 #define f_gnat_ret \
128 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
130 /* A structure used to gather together information about a statement group.
131 We use this to gather related statements, for example the "then" part
132 of a IF. In the case where it represents a lexical scope, we may also
133 have a BLOCK node corresponding to it and/or cleanups. */
135 struct GTY((chain_next ("%h.previous"))) stmt_group {
136 struct stmt_group *previous; /* Previous code group. */
137 tree stmt_list; /* List of statements for this code group. */
138 tree block; /* BLOCK for this code group, if any. */
139 tree cleanups; /* Cleanups for this code group, if any. */
142 static GTY(()) struct stmt_group *current_stmt_group;
144 /* List of unused struct stmt_group nodes. */
145 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
147 /* A structure used to record information on elaboration procedures
148 we've made and need to process.
150 ??? gnat_node should be Node_Id, but gengtype gets confused. */
152 struct GTY((chain_next ("%h.next"))) elab_info {
153 struct elab_info *next; /* Pointer to next in chain. */
154 tree elab_proc; /* Elaboration procedure. */
155 int gnat_node; /* The N_Compilation_Unit. */
158 static GTY(()) struct elab_info *elab_info_list;
160 /* Stack of exception pointer variables. Each entry is the VAR_DECL
161 that stores the address of the raised exception. Nonzero means we
162 are in an exception handler. Not used in the zero-cost case. */
163 static GTY(()) vec<tree, va_gc> *gnu_except_ptr_stack;
165 /* In ZCX case, current exception pointer. Used to re-raise it. */
166 static GTY(()) tree gnu_incoming_exc_ptr;
168 /* Stack for storing the current elaboration procedure decl. */
169 static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack;
171 /* Stack of labels to be used as a goto target instead of a return in
172 some functions. See processing for N_Subprogram_Body. */
173 static GTY(()) vec<tree, va_gc> *gnu_return_label_stack;
175 /* Stack of variable for the return value of a function with copy-in/copy-out
176 parameters. See processing for N_Subprogram_Body. */
177 static GTY(()) vec<tree, va_gc> *gnu_return_var_stack;
179 /* Structure used to record information for a range check. */
180 struct GTY(()) range_check_info_d {
181 tree low_bound;
182 tree high_bound;
183 tree type;
184 tree invariant_cond;
185 tree inserted_cond;
188 typedef struct range_check_info_d *range_check_info;
191 /* Structure used to record information for a loop. */
192 struct GTY(()) loop_info_d {
193 tree stmt;
194 tree loop_var;
195 tree low_bound;
196 tree high_bound;
197 vec<range_check_info, va_gc> *checks;
198 bool artificial;
199 bool has_checks;
200 bool warned_aggressive_loop_optimizations;
203 typedef struct loop_info_d *loop_info;
206 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
207 static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
209 /* The stacks for N_{Push,Pop}_*_Label. */
210 static GTY(()) vec<tree, va_gc> *gnu_constraint_error_label_stack;
211 static GTY(()) vec<tree, va_gc> *gnu_storage_error_label_stack;
212 static GTY(()) vec<tree, va_gc> *gnu_program_error_label_stack;
214 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
215 static enum tree_code gnu_codes[Number_Node_Kinds];
217 static void init_code_table (void);
218 static void Compilation_Unit_to_gnu (Node_Id);
219 static void record_code_position (Node_Id);
220 static void insert_code_for (Node_Id);
221 static void add_cleanup (tree, Node_Id);
222 static void add_stmt_list (List_Id);
223 static void push_exception_label_stack (vec<tree, va_gc> **, Entity_Id);
224 static tree build_stmt_group (List_Id, bool);
225 static inline bool stmt_group_may_fallthru (void);
226 static enum gimplify_status gnat_gimplify_stmt (tree *);
227 static void elaborate_all_entities (Node_Id);
228 static void process_freeze_entity (Node_Id);
229 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
230 static tree emit_range_check (tree, Node_Id, Node_Id);
231 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
232 static tree emit_check (tree, tree, int, Node_Id);
233 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
234 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
235 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
236 static bool addressable_p (tree, tree);
237 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
238 static tree extract_values (tree, tree);
239 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
240 static void validate_unchecked_conversion (Node_Id);
241 static tree maybe_implicit_deref (tree);
242 static void set_expr_location_from_node (tree, Node_Id, bool = false);
243 static void set_gnu_expr_location_from_node (tree, Node_Id);
244 static bool set_end_locus_from_node (tree, Node_Id);
245 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
246 static tree build_raise_check (int, enum exception_info_kind);
247 static tree create_init_temporary (const char *, tree, tree *, Node_Id);
249 /* Hooks for debug info back-ends, only supported and used in a restricted set
250 of configurations. */
251 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
252 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
254 /* This is the main program of the back-end. It sets up all the table
255 structures and then generates code. */
257 void
258 gigi (Node_Id gnat_root,
259 int max_gnat_node,
260 int number_name ATTRIBUTE_UNUSED,
261 struct Node *nodes_ptr,
262 struct Flags *flags_ptr,
263 Node_Id *next_node_ptr,
264 Node_Id *prev_node_ptr,
265 struct Elist_Header *elists_ptr,
266 struct Elmt_Item *elmts_ptr,
267 struct String_Entry *strings_ptr,
268 Char_Code *string_chars_ptr,
269 struct List_Header *list_headers_ptr,
270 Nat number_file,
271 struct File_Info_Type *file_info_ptr,
272 Entity_Id standard_boolean,
273 Entity_Id standard_integer,
274 Entity_Id standard_character,
275 Entity_Id standard_long_long_float,
276 Entity_Id standard_exception_type,
277 Int gigi_operating_mode)
279 Node_Id gnat_iter;
280 Entity_Id gnat_literal;
281 tree t, ftype, int64_type;
282 struct elab_info *info;
283 int i;
285 max_gnat_nodes = max_gnat_node;
287 Nodes_Ptr = nodes_ptr;
288 Flags_Ptr = flags_ptr;
289 Next_Node_Ptr = next_node_ptr;
290 Prev_Node_Ptr = prev_node_ptr;
291 Elists_Ptr = elists_ptr;
292 Elmts_Ptr = elmts_ptr;
293 Strings_Ptr = strings_ptr;
294 String_Chars_Ptr = string_chars_ptr;
295 List_Headers_Ptr = list_headers_ptr;
297 type_annotate_only = (gigi_operating_mode == 1);
299 for (i = 0; i < number_file; i++)
301 /* Use the identifier table to make a permanent copy of the filename as
302 the name table gets reallocated after Gigi returns but before all the
303 debugging information is output. The __gnat_to_canonical_file_spec
304 call translates filenames from pragmas Source_Reference that contain
305 host style syntax not understood by gdb. */
306 const char *filename
307 = IDENTIFIER_POINTER
308 (get_identifier
309 (__gnat_to_canonical_file_spec
310 (Get_Name_String (file_info_ptr[i].File_Name))));
312 /* We rely on the order isomorphism between files and line maps. */
313 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i);
315 /* We create the line map for a source file at once, with a fixed number
316 of columns chosen to avoid jumping over the next power of 2. */
317 linemap_add (line_table, LC_ENTER, 0, filename, 1);
318 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
319 linemap_position_for_column (line_table, 252 - 1);
320 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
323 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
325 /* Declare the name of the compilation unit as the first global
326 name in order to make the middle-end fully deterministic. */
327 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
328 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
330 /* Initialize ourselves. */
331 init_code_table ();
332 init_gnat_decl ();
333 init_gnat_utils ();
335 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
336 errors. */
337 if (type_annotate_only)
339 TYPE_SIZE (void_type_node) = bitsize_zero_node;
340 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
343 /* Enable GNAT stack checking method if needed */
344 if (!Stack_Check_Probes_On_Target)
345 set_stack_check_libfunc ("_gnat_stack_check");
347 /* Retrieve alignment settings. */
348 double_float_alignment = get_target_double_float_alignment ();
349 double_scalar_alignment = get_target_double_scalar_alignment ();
351 /* Record the builtin types. Define `integer' and `character' first so that
352 dbx will output them first. */
353 record_builtin_type ("integer", integer_type_node, false);
354 record_builtin_type ("character", unsigned_char_type_node, false);
355 record_builtin_type ("boolean", boolean_type_node, false);
356 record_builtin_type ("void", void_type_node, false);
358 /* Save the type we made for integer as the type for Standard.Integer. */
359 save_gnu_tree (Base_Type (standard_integer),
360 TYPE_NAME (integer_type_node),
361 false);
363 /* Likewise for character as the type for Standard.Character. */
364 save_gnu_tree (Base_Type (standard_character),
365 TYPE_NAME (unsigned_char_type_node),
366 false);
368 /* Likewise for boolean as the type for Standard.Boolean. */
369 save_gnu_tree (Base_Type (standard_boolean),
370 TYPE_NAME (boolean_type_node),
371 false);
372 gnat_literal = First_Literal (Base_Type (standard_boolean));
373 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
374 gcc_assert (t == boolean_false_node);
375 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
376 boolean_type_node, t, true, false, false, false,
377 true, false, NULL, gnat_literal);
378 save_gnu_tree (gnat_literal, t, false);
379 gnat_literal = Next_Literal (gnat_literal);
380 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
381 gcc_assert (t == boolean_true_node);
382 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
383 boolean_type_node, t, true, false, false, false,
384 true, false, NULL, gnat_literal);
385 save_gnu_tree (gnat_literal, t, false);
387 void_ftype = build_function_type_list (void_type_node, NULL_TREE);
388 ptr_void_ftype = build_pointer_type (void_ftype);
390 /* Now declare run-time functions. */
391 ftype = build_function_type_list (ptr_type_node, sizetype, NULL_TREE);
393 /* malloc is a function declaration tree for a function to allocate
394 memory. */
395 malloc_decl
396 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
397 ftype,
398 NULL_TREE, is_disabled, true, true, true, false,
399 NULL, Empty);
400 DECL_IS_MALLOC (malloc_decl) = 1;
402 /* free is a function declaration tree for a function to free memory. */
403 free_decl
404 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
405 build_function_type_list (void_type_node,
406 ptr_type_node,
407 NULL_TREE),
408 NULL_TREE, is_disabled, true, true, true, false,
409 NULL, Empty);
411 /* This is used for 64-bit multiplication with overflow checking. */
412 int64_type = gnat_type_for_size (64, 0);
413 mulv64_decl
414 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
415 build_function_type_list (int64_type, int64_type,
416 int64_type, NULL_TREE),
417 NULL_TREE, is_disabled, true, true, true, false,
418 NULL, Empty);
420 /* Name of the _Parent field in tagged record types. */
421 parent_name_id = get_identifier (Get_Name_String (Name_uParent));
423 /* Name of the Exception_Data type defined in System.Standard_Library. */
424 exception_data_name_id
425 = get_identifier ("system__standard_library__exception_data");
427 /* Make the types and functions used for exception processing. */
428 except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type));
430 jmpbuf_type
431 = build_array_type (gnat_type_for_mode (Pmode, 0),
432 build_index_type (size_int (5)));
433 record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
434 jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
436 /* Functions to get and set the jumpbuf pointer for the current thread. */
437 get_jmpbuf_decl
438 = create_subprog_decl
439 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
440 NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
441 NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
443 set_jmpbuf_decl
444 = create_subprog_decl
445 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
446 NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
447 NULL_TREE),
448 NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
450 get_excptr_decl
451 = create_subprog_decl
452 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
453 build_function_type_list (build_pointer_type (except_type_node),
454 NULL_TREE),
455 NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
457 not_handled_by_others_decl = get_identifier ("not_handled_by_others");
458 for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
459 if (DECL_NAME (t) == not_handled_by_others_decl)
461 not_handled_by_others_decl = t;
462 break;
464 gcc_assert (DECL_P (not_handled_by_others_decl));
466 /* setjmp returns an integer and has one operand, which is a pointer to
467 a jmpbuf. */
468 setjmp_decl
469 = create_subprog_decl
470 (get_identifier ("__builtin_setjmp"), NULL_TREE,
471 build_function_type_list (integer_type_node, jmpbuf_ptr_type,
472 NULL_TREE),
473 NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
474 DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
475 DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
477 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
478 address. */
479 update_setjmp_buf_decl
480 = create_subprog_decl
481 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
482 build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
483 NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
484 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
485 DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
487 raise_nodefer_decl
488 = create_subprog_decl
489 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
490 build_function_type_list (void_type_node,
491 build_pointer_type (except_type_node),
492 NULL_TREE),
493 NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
495 /* Indicate that it never returns. */
496 TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
497 TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
498 TREE_TYPE (raise_nodefer_decl)
499 = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
500 TYPE_QUAL_VOLATILE);
502 reraise_zcx_decl
503 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
504 ftype, NULL_TREE,
505 is_disabled, true, true, true, false,
506 NULL, Empty);
507 /* Indicate that these never return. */
508 TREE_THIS_VOLATILE (reraise_zcx_decl) = 1;
509 TREE_SIDE_EFFECTS (reraise_zcx_decl) = 1;
510 TREE_TYPE (reraise_zcx_decl)
511 = build_qualified_type (TREE_TYPE (reraise_zcx_decl), TYPE_QUAL_VOLATILE);
513 set_exception_parameter_decl
514 = create_subprog_decl
515 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
516 build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
517 NULL_TREE),
518 NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
520 /* Hooks to call when entering/leaving an exception handler. */
521 ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
523 begin_handler_decl
524 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
525 ftype, NULL_TREE,
526 is_disabled, true, true, true, false,
527 NULL, Empty);
529 end_handler_decl
530 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
531 ftype, NULL_TREE,
532 is_disabled, true, true, true, false,
533 NULL, Empty);
535 unhandled_except_decl
536 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
537 NULL_TREE, ftype, NULL_TREE,
538 is_disabled, true, true, true, false,
539 NULL, Empty);
541 /* Dummy objects to materialize "others" and "all others" in the exception
542 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
543 the types to use. */
544 others_decl
545 = create_var_decl (get_identifier ("OTHERS"),
546 get_identifier ("__gnat_others_value"),
547 unsigned_char_type_node, NULL_TREE,
548 true, false, true, false, true, false,
549 NULL, Empty);
551 all_others_decl
552 = create_var_decl (get_identifier ("ALL_OTHERS"),
553 get_identifier ("__gnat_all_others_value"),
554 unsigned_char_type_node, NULL_TREE,
555 true, false, true, false, true, false,
556 NULL, Empty);
558 unhandled_others_decl
559 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
560 get_identifier ("__gnat_unhandled_others_value"),
561 unsigned_char_type_node, NULL_TREE,
562 true, false, true, false, true, false,
563 NULL, Empty);
565 /* If in no exception handlers mode, all raise statements are redirected to
566 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
567 this procedure will never be called in this mode. */
568 if (No_Exception_Handlers_Set ())
570 tree decl
571 = create_subprog_decl
572 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
573 build_function_type_list (void_type_node,
574 build_pointer_type
575 (unsigned_char_type_node),
576 integer_type_node, NULL_TREE),
577 NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
578 TREE_THIS_VOLATILE (decl) = 1;
579 TREE_SIDE_EFFECTS (decl) = 1;
580 TREE_TYPE (decl)
581 = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
582 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
583 gnat_raise_decls[i] = decl;
585 else
587 /* Otherwise, make one decl for each exception reason. */
588 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
589 gnat_raise_decls[i] = build_raise_check (i, exception_simple);
590 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
591 gnat_raise_decls_ext[i]
592 = build_raise_check (i,
593 i == CE_Index_Check_Failed
594 || i == CE_Range_Check_Failed
595 || i == CE_Invalid_Data
596 ? exception_range : exception_column);
599 /* Build the special descriptor type and its null node if needed. */
600 if (TARGET_VTABLE_USES_DESCRIPTORS)
602 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
603 tree field_list = NULL_TREE;
604 int j;
605 vec<constructor_elt, va_gc> *null_vec = NULL;
606 constructor_elt *elt;
608 fdesc_type_node = make_node (RECORD_TYPE);
609 vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS);
610 elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
612 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
614 tree field
615 = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
616 NULL_TREE, NULL_TREE, 0, 1);
617 DECL_CHAIN (field) = field_list;
618 field_list = field;
619 elt->index = field;
620 elt->value = null_node;
621 elt--;
624 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
625 record_builtin_type ("descriptor", fdesc_type_node, true);
626 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
629 longest_float_type_node
630 = get_unpadded_type (Base_Type (standard_long_long_float));
632 main_identifier_node = get_identifier ("main");
634 /* Install the builtins we might need, either internally or as
635 user available facilities for Intrinsic imports. */
636 gnat_install_builtins ();
638 vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
639 vec_safe_push (gnu_constraint_error_label_stack, NULL_TREE);
640 vec_safe_push (gnu_storage_error_label_stack, NULL_TREE);
641 vec_safe_push (gnu_program_error_label_stack, NULL_TREE);
643 /* Process any Pragma Ident for the main unit. */
644 if (Present (Ident_String (Main_Unit)))
645 targetm.asm_out.output_ident
646 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
648 /* If we are using the GCC exception mechanism, let GCC know. */
649 if (Exception_Mechanism == Back_End_Exceptions)
650 gnat_init_gcc_eh ();
652 /* Initialize the GCC support for FP operations. */
653 gnat_init_gcc_fp ();
655 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
656 if (No_Strict_Aliasing_CP)
657 flag_strict_aliasing = 0;
659 /* Save the current optimization options again after the above possible
660 global_options changes. */
661 optimization_default_node = build_optimization_node (&global_options);
662 optimization_current_node = optimization_default_node;
664 /* Now translate the compilation unit proper. */
665 Compilation_Unit_to_gnu (gnat_root);
667 /* Disable -Waggressive-loop-optimizations since we implement our own
668 version of the warning. */
669 warn_aggressive_loop_optimizations = 0;
671 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
672 the very end to avoid having to second-guess the front-end when we run
673 into dummy nodes during the regular processing. */
674 for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++)
675 validate_unchecked_conversion (gnat_iter);
676 gnat_validate_uc_list.release ();
678 /* Finally see if we have any elaboration procedures to deal with. */
679 for (info = elab_info_list; info; info = info->next)
681 tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
683 /* We should have a BIND_EXPR but it may not have any statements in it.
684 If it doesn't have any, we have nothing to do except for setting the
685 flag on the GNAT node. Otherwise, process the function as others. */
686 gnu_stmts = gnu_body;
687 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
688 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
689 if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
690 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
691 else
693 begin_subprog_body (info->elab_proc);
694 end_subprog_body (gnu_body);
695 rest_of_subprog_body_compilation (info->elab_proc);
699 /* Destroy ourselves. */
700 destroy_gnat_decl ();
701 destroy_gnat_utils ();
703 /* We cannot track the location of errors past this point. */
704 error_gnat_node = Empty;
707 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
708 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
710 static tree
711 build_raise_check (int check, enum exception_info_kind kind)
713 tree result, ftype;
714 const char pfx[] = "__gnat_rcheck_";
716 strcpy (Name_Buffer, pfx);
717 Name_Len = sizeof (pfx) - 1;
718 Get_RT_Exception_Name (check);
720 if (kind == exception_simple)
722 Name_Buffer[Name_Len] = 0;
723 ftype
724 = build_function_type_list (void_type_node,
725 build_pointer_type
726 (unsigned_char_type_node),
727 integer_type_node, NULL_TREE);
729 else
731 tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
733 strcpy (Name_Buffer + Name_Len, "_ext");
734 Name_Buffer[Name_Len + 4] = 0;
735 ftype
736 = build_function_type_list (void_type_node,
737 build_pointer_type
738 (unsigned_char_type_node),
739 integer_type_node, integer_type_node,
740 t, t, NULL_TREE);
743 result
744 = create_subprog_decl (get_identifier (Name_Buffer),
745 NULL_TREE, ftype, NULL_TREE,
746 is_disabled, true, true, true, false,
747 NULL, Empty);
749 /* Indicate that it never returns. */
750 TREE_THIS_VOLATILE (result) = 1;
751 TREE_SIDE_EFFECTS (result) = 1;
752 TREE_TYPE (result)
753 = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE);
755 return result;
758 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
759 an N_Attribute_Reference. */
761 static int
762 lvalue_required_for_attribute_p (Node_Id gnat_node)
764 switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
766 case Attr_Pos:
767 case Attr_Val:
768 case Attr_Pred:
769 case Attr_Succ:
770 case Attr_First:
771 case Attr_Last:
772 case Attr_Range_Length:
773 case Attr_Length:
774 case Attr_Object_Size:
775 case Attr_Value_Size:
776 case Attr_Component_Size:
777 case Attr_Descriptor_Size:
778 case Attr_Max_Size_In_Storage_Elements:
779 case Attr_Min:
780 case Attr_Max:
781 case Attr_Null_Parameter:
782 case Attr_Passed_By_Reference:
783 case Attr_Mechanism_Code:
784 case Attr_Machine:
785 case Attr_Model:
786 return 0;
788 case Attr_Address:
789 case Attr_Access:
790 case Attr_Unchecked_Access:
791 case Attr_Unrestricted_Access:
792 case Attr_Code_Address:
793 case Attr_Pool_Address:
794 case Attr_Size:
795 case Attr_Alignment:
796 case Attr_Bit_Position:
797 case Attr_Position:
798 case Attr_First_Bit:
799 case Attr_Last_Bit:
800 case Attr_Bit:
801 case Attr_Asm_Input:
802 case Attr_Asm_Output:
803 default:
804 return 1;
808 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
809 is the type that will be used for GNAT_NODE in the translated GNU tree.
810 CONSTANT indicates whether the underlying object represented by GNAT_NODE
811 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
812 whether its value is the address of a constant and ALIASED whether it is
813 aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
815 The function climbs up the GNAT tree starting from the node and returns 1
816 upon encountering a node that effectively requires an lvalue downstream.
817 It returns int instead of bool to facilitate usage in non-purely binary
818 logic contexts. */
820 static int
821 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
822 bool address_of_constant, bool aliased)
824 Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
826 switch (Nkind (gnat_parent))
828 case N_Reference:
829 return 1;
831 case N_Attribute_Reference:
832 return lvalue_required_for_attribute_p (gnat_parent);
834 case N_Parameter_Association:
835 case N_Function_Call:
836 case N_Procedure_Call_Statement:
837 /* If the parameter is by reference, an lvalue is required. */
838 return (!constant
839 || must_pass_by_ref (gnu_type)
840 || default_pass_by_ref (gnu_type));
842 case N_Indexed_Component:
843 /* Only the array expression can require an lvalue. */
844 if (Prefix (gnat_parent) != gnat_node)
845 return 0;
847 /* ??? Consider that referencing an indexed component with a variable
848 index forces the whole aggregate to memory. Note that testing only
849 for literals is conservative, any static expression in the RM sense
850 could probably be accepted with some additional work. */
851 for (gnat_temp = First (Expressions (gnat_parent));
852 Present (gnat_temp);
853 gnat_temp = Next (gnat_temp))
854 if (Nkind (gnat_temp) != N_Character_Literal
855 && Nkind (gnat_temp) != N_Integer_Literal
856 && !(Is_Entity_Name (gnat_temp)
857 && Ekind (Entity (gnat_temp)) == E_Enumeration_Literal))
858 return 1;
860 /* ... fall through ... */
862 case N_Slice:
863 /* Only the array expression can require an lvalue. */
864 if (Prefix (gnat_parent) != gnat_node)
865 return 0;
867 aliased |= Has_Aliased_Components (Etype (gnat_node));
868 return lvalue_required_p (gnat_parent, gnu_type, constant,
869 address_of_constant, aliased);
871 case N_Selected_Component:
872 aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
873 return lvalue_required_p (gnat_parent, gnu_type, constant,
874 address_of_constant, aliased);
876 case N_Object_Renaming_Declaration:
877 /* We need to preserve addresses through a renaming. */
878 return 1;
880 case N_Object_Declaration:
881 /* We cannot use a constructor if this is an atomic object because
882 the actual assignment might end up being done component-wise. */
883 return (!constant
884 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
885 && Is_Atomic_Or_VFA (Defining_Entity (gnat_parent)))
886 /* We don't use a constructor if this is a class-wide object
887 because the effective type of the object is the equivalent
888 type of the class-wide subtype and it smashes most of the
889 data into an array of bytes to which we cannot convert. */
890 || Ekind ((Etype (Defining_Entity (gnat_parent))))
891 == E_Class_Wide_Subtype);
893 case N_Assignment_Statement:
894 /* We cannot use a constructor if the LHS is an atomic object because
895 the actual assignment might end up being done component-wise. */
896 return (!constant
897 || Name (gnat_parent) == gnat_node
898 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
899 && Is_Entity_Name (Name (gnat_parent))
900 && Is_Atomic_Or_VFA (Entity (Name (gnat_parent)))));
902 case N_Unchecked_Type_Conversion:
903 if (!constant)
904 return 1;
906 /* ... fall through ... */
908 case N_Type_Conversion:
909 case N_Qualified_Expression:
910 /* We must look through all conversions because we may need to bypass
911 an intermediate conversion that is meant to be purely formal. */
912 return lvalue_required_p (gnat_parent,
913 get_unpadded_type (Etype (gnat_parent)),
914 constant, address_of_constant, aliased);
916 case N_Allocator:
917 /* We should only reach here through the N_Qualified_Expression case.
918 Force an lvalue for composite types since a block-copy to the newly
919 allocated area of memory is made. */
920 return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
922 case N_Explicit_Dereference:
923 /* We look through dereferences for address of constant because we need
924 to handle the special cases listed above. */
925 if (constant && address_of_constant)
926 return lvalue_required_p (gnat_parent,
927 get_unpadded_type (Etype (gnat_parent)),
928 true, false, true);
930 /* ... fall through ... */
932 default:
933 return 0;
936 gcc_unreachable ();
939 /* Return true if T is a constant DECL node that can be safely replaced
940 by its initializer. */
942 static bool
943 constant_decl_with_initializer_p (tree t)
945 if (!TREE_CONSTANT (t) || !DECL_P (t) || !DECL_INITIAL (t))
946 return false;
948 /* Return false for aggregate types that contain a placeholder since
949 their initializers cannot be manipulated easily. */
950 if (AGGREGATE_TYPE_P (TREE_TYPE (t))
951 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t))
952 && type_contains_placeholder_p (TREE_TYPE (t)))
953 return false;
955 return true;
958 /* Return an expression equivalent to EXP but where constant DECL nodes
959 have been replaced by their initializer. */
961 static tree
962 fold_constant_decl_in_expr (tree exp)
964 enum tree_code code = TREE_CODE (exp);
965 tree op0;
967 switch (code)
969 case CONST_DECL:
970 case VAR_DECL:
971 if (!constant_decl_with_initializer_p (exp))
972 return exp;
974 return DECL_INITIAL (exp);
976 case BIT_FIELD_REF:
977 case COMPONENT_REF:
978 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
979 if (op0 == TREE_OPERAND (exp, 0))
980 return exp;
982 return fold_build3 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
983 TREE_OPERAND (exp, 2));
985 case ARRAY_REF:
986 case ARRAY_RANGE_REF:
987 /* If the index is not itself constant, then nothing can be folded. */
988 if (!TREE_CONSTANT (TREE_OPERAND (exp, 1)))
989 return exp;
990 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
991 if (op0 == TREE_OPERAND (exp, 0))
992 return exp;
994 return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
995 TREE_OPERAND (exp, 2), TREE_OPERAND (exp, 3)));
997 case REALPART_EXPR:
998 case IMAGPART_EXPR:
999 case VIEW_CONVERT_EXPR:
1000 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1001 if (op0 == TREE_OPERAND (exp, 0))
1002 return exp;
1004 return fold_build1 (code, TREE_TYPE (exp), op0);
1006 default:
1007 return exp;
1010 gcc_unreachable ();
1013 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1014 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1015 to where we should place the result type. */
1017 static tree
1018 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
1020 Node_Id gnat_temp, gnat_temp_type;
1021 tree gnu_result, gnu_result_type;
1023 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1024 specific circumstances only, so evaluated lazily. < 0 means
1025 unknown, > 0 means known true, 0 means known false. */
1026 int require_lvalue = -1;
1028 /* If GNAT_NODE is a constant, whether we should use the initialization
1029 value instead of the constant entity, typically for scalars with an
1030 address clause when the parent doesn't require an lvalue. */
1031 bool use_constant_initializer = false;
1033 /* If the Etype of this node does not equal the Etype of the Entity,
1034 something is wrong with the entity map, probably in generic
1035 instantiation. However, this does not apply to types. Since we sometime
1036 have strange Ekind's, just do this test for objects. Also, if the Etype of
1037 the Entity is private, the Etype of the N_Identifier is allowed to be the
1038 full type and also we consider a packed array type to be the same as the
1039 original type. Similarly, a class-wide type is equivalent to a subtype of
1040 itself. Finally, if the types are Itypes, one may be a copy of the other,
1041 which is also legal. */
1042 gnat_temp = ((Nkind (gnat_node) == N_Defining_Identifier
1043 || Nkind (gnat_node) == N_Defining_Operator_Symbol)
1044 ? gnat_node : Entity (gnat_node));
1045 gnat_temp_type = Etype (gnat_temp);
1047 gcc_assert (Etype (gnat_node) == gnat_temp_type
1048 || (Is_Packed (gnat_temp_type)
1049 && (Etype (gnat_node)
1050 == Packed_Array_Impl_Type (gnat_temp_type)))
1051 || (Is_Class_Wide_Type (Etype (gnat_node)))
1052 || (IN (Ekind (gnat_temp_type), Private_Kind)
1053 && Present (Full_View (gnat_temp_type))
1054 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
1055 || (Is_Packed (Full_View (gnat_temp_type))
1056 && (Etype (gnat_node)
1057 == Packed_Array_Impl_Type
1058 (Full_View (gnat_temp_type))))))
1059 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
1060 || !(Ekind (gnat_temp) == E_Variable
1061 || Ekind (gnat_temp) == E_Component
1062 || Ekind (gnat_temp) == E_Constant
1063 || Ekind (gnat_temp) == E_Loop_Parameter
1064 || IN (Ekind (gnat_temp), Formal_Kind)));
1066 /* If this is a reference to a deferred constant whose partial view is an
1067 unconstrained private type, the proper type is on the full view of the
1068 constant, not on the full view of the type, which may be unconstrained.
1070 This may be a reference to a type, for example in the prefix of the
1071 attribute Position, generated for dispatching code (see Make_DT in
1072 exp_disp,adb). In that case we need the type itself, not is parent,
1073 in particular if it is a derived type */
1074 if (Ekind (gnat_temp) == E_Constant
1075 && Is_Private_Type (gnat_temp_type)
1076 && (Has_Unknown_Discriminants (gnat_temp_type)
1077 || (Present (Full_View (gnat_temp_type))
1078 && Has_Discriminants (Full_View (gnat_temp_type))))
1079 && Present (Full_View (gnat_temp)))
1081 gnat_temp = Full_View (gnat_temp);
1082 gnat_temp_type = Etype (gnat_temp);
1084 else
1086 /* We want to use the Actual_Subtype if it has already been elaborated,
1087 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
1088 simplify things. */
1089 if ((Ekind (gnat_temp) == E_Constant
1090 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
1091 && !(Is_Array_Type (Etype (gnat_temp))
1092 && Present (Packed_Array_Impl_Type (Etype (gnat_temp))))
1093 && Present (Actual_Subtype (gnat_temp))
1094 && present_gnu_tree (Actual_Subtype (gnat_temp)))
1095 gnat_temp_type = Actual_Subtype (gnat_temp);
1096 else
1097 gnat_temp_type = Etype (gnat_node);
1100 /* Expand the type of this identifier first, in case it is an enumeral
1101 literal, which only get made when the type is expanded. There is no
1102 order-of-elaboration issue here. */
1103 gnu_result_type = get_unpadded_type (gnat_temp_type);
1105 /* If this is a non-imported elementary constant with an address clause,
1106 retrieve the value instead of a pointer to be dereferenced unless
1107 an lvalue is required. This is generally more efficient and actually
1108 required if this is a static expression because it might be used
1109 in a context where a dereference is inappropriate, such as a case
1110 statement alternative or a record discriminant. There is no possible
1111 volatile-ness short-circuit here since Volatile constants must be
1112 imported per C.6. */
1113 if (Ekind (gnat_temp) == E_Constant
1114 && Is_Elementary_Type (gnat_temp_type)
1115 && !Is_Imported (gnat_temp)
1116 && Present (Address_Clause (gnat_temp)))
1118 require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
1119 false, Is_Aliased (gnat_temp));
1120 use_constant_initializer = !require_lvalue;
1123 if (use_constant_initializer)
1125 /* If this is a deferred constant, the initializer is attached to
1126 the full view. */
1127 if (Present (Full_View (gnat_temp)))
1128 gnat_temp = Full_View (gnat_temp);
1130 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
1132 else
1133 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
1135 /* Some objects (such as parameters passed by reference, globals of
1136 variable size, and renamed objects) actually represent the address
1137 of the object. In that case, we must do the dereference. Likewise,
1138 deal with parameters to foreign convention subprograms. */
1139 if (DECL_P (gnu_result)
1140 && (DECL_BY_REF_P (gnu_result)
1141 || (TREE_CODE (gnu_result) == PARM_DECL
1142 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
1144 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1146 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1147 if (TREE_CODE (gnu_result) == PARM_DECL
1148 && DECL_BY_COMPONENT_PTR_P (gnu_result))
1149 gnu_result
1150 = convert (build_pointer_type (gnu_result_type), gnu_result);
1152 /* If it's a CONST_DECL, return the underlying constant like below. */
1153 else if (TREE_CODE (gnu_result) == CONST_DECL
1154 && !(DECL_CONST_ADDRESS_P (gnu_result)
1155 && lvalue_required_p (gnat_node, gnu_result_type, true,
1156 true, false)))
1157 gnu_result = DECL_INITIAL (gnu_result);
1159 /* If it's a renaming pointer, get to the renamed object. */
1160 if (TREE_CODE (gnu_result) == VAR_DECL
1161 && !DECL_LOOP_PARM_P (gnu_result)
1162 && DECL_RENAMED_OBJECT (gnu_result))
1163 gnu_result = DECL_RENAMED_OBJECT (gnu_result);
1165 /* Otherwise, do the final dereference. */
1166 else
1168 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1170 if ((TREE_CODE (gnu_result) == INDIRECT_REF
1171 || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
1172 && No (Address_Clause (gnat_temp)))
1173 TREE_THIS_NOTRAP (gnu_result) = 1;
1175 if (read_only)
1176 TREE_READONLY (gnu_result) = 1;
1180 /* If we have a constant declaration and its initializer, try to return the
1181 latter to avoid the need to call fold in lots of places and the need for
1182 elaboration code if this identifier is used as an initializer itself. */
1183 if (constant_decl_with_initializer_p (gnu_result))
1185 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1186 && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1187 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1188 && DECL_CONST_ADDRESS_P (gnu_result));
1190 /* If there is a (corresponding) variable or this is the address of a
1191 constant, we only want to return the initializer if an lvalue isn't
1192 required. Evaluate this now if we have not already done so. */
1193 if ((!constant_only || address_of_constant) && require_lvalue < 0)
1194 require_lvalue
1195 = lvalue_required_p (gnat_node, gnu_result_type, true,
1196 address_of_constant, Is_Aliased (gnat_temp));
1198 /* Finally retrieve the initializer if this is deemed valid. */
1199 if ((constant_only && !address_of_constant) || !require_lvalue)
1200 gnu_result = DECL_INITIAL (gnu_result);
1203 /* But for a constant renaming we couldn't do that incrementally for its
1204 definition because of the need to return an lvalue so, if the present
1205 context doesn't itself require an lvalue, we try again here. */
1206 else if (Ekind (gnat_temp) == E_Constant
1207 && Is_Elementary_Type (gnat_temp_type)
1208 && Present (Renamed_Object (gnat_temp)))
1210 if (require_lvalue < 0)
1211 require_lvalue
1212 = lvalue_required_p (gnat_node, gnu_result_type, true, false,
1213 Is_Aliased (gnat_temp));
1214 if (!require_lvalue)
1215 gnu_result = fold_constant_decl_in_expr (gnu_result);
1218 /* The GNAT tree has the type of a function set to its result type, so we
1219 adjust here. Also use the type of the result if the Etype is a subtype
1220 that is nominally unconstrained. Likewise if this is a deferred constant
1221 of a discriminated type whose full view can be elaborated statically, to
1222 avoid problematic conversions to the nominal subtype. But remove any
1223 padding from the resulting type. */
1224 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1225 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)
1226 || (Ekind (gnat_temp) == E_Constant
1227 && Present (Full_View (gnat_temp))
1228 && Has_Discriminants (gnat_temp_type)
1229 && TREE_CODE (gnu_result) == CONSTRUCTOR))
1231 gnu_result_type = TREE_TYPE (gnu_result);
1232 if (TYPE_IS_PADDING_P (gnu_result_type))
1233 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1236 *gnu_result_type_p = gnu_result_type;
1238 return gnu_result;
1241 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1242 any statements we generate. */
1244 static tree
1245 Pragma_to_gnu (Node_Id gnat_node)
1247 tree gnu_result = alloc_stmt_list ();
1248 unsigned char pragma_id;
1249 Node_Id gnat_temp;
1251 /* Do nothing if we are just annotating types and check for (and ignore)
1252 unrecognized pragmas. */
1253 if (type_annotate_only
1254 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1255 return gnu_result;
1257 pragma_id = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
1258 switch (pragma_id)
1260 case Pragma_Inspection_Point:
1261 /* Do nothing at top level: all such variables are already viewable. */
1262 if (global_bindings_p ())
1263 break;
1265 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1266 Present (gnat_temp);
1267 gnat_temp = Next (gnat_temp))
1269 Node_Id gnat_expr = Expression (gnat_temp);
1270 tree gnu_expr = gnat_to_gnu (gnat_expr);
1271 int use_address;
1272 machine_mode mode;
1273 tree asm_constraint = NULL_TREE;
1274 #ifdef ASM_COMMENT_START
1275 char *comment;
1276 #endif
1278 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1279 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1281 /* Use the value only if it fits into a normal register,
1282 otherwise use the address. */
1283 mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1284 use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1285 && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1286 || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1288 if (use_address)
1289 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1291 #ifdef ASM_COMMENT_START
1292 comment = concat (ASM_COMMENT_START,
1293 " inspection point: ",
1294 Get_Name_String (Chars (gnat_expr)),
1295 use_address ? " address" : "",
1296 " is in %0",
1297 NULL);
1298 asm_constraint = build_string (strlen (comment), comment);
1299 free (comment);
1300 #endif
1301 gnu_expr = build5 (ASM_EXPR, void_type_node,
1302 asm_constraint,
1303 NULL_TREE,
1304 tree_cons
1305 (build_tree_list (NULL_TREE,
1306 build_string (1, "g")),
1307 gnu_expr, NULL_TREE),
1308 NULL_TREE, NULL_TREE);
1309 ASM_VOLATILE_P (gnu_expr) = 1;
1310 set_expr_location_from_node (gnu_expr, gnat_node);
1311 append_to_statement_list (gnu_expr, &gnu_result);
1313 break;
1315 case Pragma_Loop_Optimize:
1316 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1317 Present (gnat_temp);
1318 gnat_temp = Next (gnat_temp))
1320 tree gnu_loop_stmt = gnu_loop_stack->last ()->stmt;
1322 switch (Chars (Expression (gnat_temp)))
1324 case Name_Ivdep:
1325 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
1326 break;
1328 case Name_No_Unroll:
1329 LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1;
1330 break;
1332 case Name_Unroll:
1333 LOOP_STMT_UNROLL (gnu_loop_stmt) = 1;
1334 break;
1336 case Name_No_Vector:
1337 LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1;
1338 break;
1340 case Name_Vector:
1341 LOOP_STMT_VECTOR (gnu_loop_stmt) = 1;
1342 break;
1344 default:
1345 gcc_unreachable ();
1348 break;
1350 case Pragma_Optimize:
1351 switch (Chars (Expression
1352 (First (Pragma_Argument_Associations (gnat_node)))))
1354 case Name_Off:
1355 if (optimize)
1356 post_error ("must specify -O0?", gnat_node);
1357 break;
1359 case Name_Space:
1360 if (!optimize_size)
1361 post_error ("must specify -Os?", gnat_node);
1362 break;
1364 case Name_Time:
1365 if (!optimize)
1366 post_error ("insufficient -O value?", gnat_node);
1367 break;
1369 default:
1370 gcc_unreachable ();
1372 break;
1374 case Pragma_Reviewable:
1375 if (write_symbols == NO_DEBUG)
1376 post_error ("must specify -g?", gnat_node);
1377 break;
1379 case Pragma_Warning_As_Error:
1380 case Pragma_Warnings:
1382 Node_Id gnat_expr;
1383 /* Preserve the location of the pragma. */
1384 const location_t location = input_location;
1385 struct cl_option_handlers handlers;
1386 unsigned int option_index;
1387 diagnostic_t kind;
1388 bool imply;
1390 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1392 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1393 if (Nkind (Expression (gnat_temp)) == N_String_Literal)
1395 switch (pragma_id)
1397 case Pragma_Warning_As_Error:
1398 kind = DK_ERROR;
1399 imply = false;
1400 break;
1402 case Pragma_Warnings:
1403 kind = DK_WARNING;
1404 imply = true;
1405 break;
1407 default:
1408 gcc_unreachable ();
1411 gnat_expr = Expression (gnat_temp);
1414 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1415 else if (Nkind (Expression (gnat_temp)) == N_Identifier)
1417 switch (Chars (Expression (gnat_temp)))
1419 case Name_Off:
1420 kind = DK_IGNORED;
1421 break;
1423 case Name_On:
1424 kind = DK_WARNING;
1425 break;
1427 default:
1428 gcc_unreachable ();
1431 /* Deal with optional pattern (but ignore Reason => "..."). */
1432 if (Present (Next (gnat_temp))
1433 && Chars (Next (gnat_temp)) != Name_Reason)
1435 /* pragma Warnings (On | Off, Name) is handled differently. */
1436 if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal)
1437 break;
1439 gnat_expr = Expression (Next (gnat_temp));
1441 else
1442 gnat_expr = Empty;
1444 imply = false;
1447 else
1448 gcc_unreachable ();
1450 /* This is the same implementation as in the C family of compilers. */
1451 const unsigned int lang_mask = CL_Ada | CL_COMMON;
1452 if (Present (gnat_expr))
1454 tree gnu_expr = gnat_to_gnu (gnat_expr);
1455 const char *option_string = TREE_STRING_POINTER (gnu_expr);
1456 const int len = TREE_STRING_LENGTH (gnu_expr);
1457 if (len < 3 || option_string[0] != '-' || option_string[1] != 'W')
1458 break;
1459 option_index = find_opt (option_string + 1, lang_mask);
1460 if (option_index == OPT_SPECIAL_unknown)
1462 post_error ("?unknown -W switch", gnat_node);
1463 break;
1465 else if (!(cl_options[option_index].flags & CL_WARNING))
1467 post_error ("?-W switch does not control warning", gnat_node);
1468 break;
1470 else if (!(cl_options[option_index].flags & lang_mask))
1472 post_error ("?-W switch not valid for Ada", gnat_node);
1473 break;
1476 else
1477 option_index = 0;
1479 set_default_handlers (&handlers);
1480 control_warning_option (option_index, (int) kind, imply, location,
1481 lang_mask, &handlers, &global_options,
1482 &global_options_set, global_dc);
1484 break;
1486 default:
1487 break;
1490 return gnu_result;
1494 /* Check the inlining status of nested function FNDECL in the current context.
1496 If a non-inline nested function is referenced from an inline external
1497 function, we cannot honor both requests at the same time without cloning
1498 the nested function in the current unit since it is private to its unit.
1499 We could inline it as well but it's probably better to err on the side
1500 of too little inlining.
1502 This must be invoked only on nested functions present in the source code
1503 and not on nested functions generated by the compiler, e.g. finalizers,
1504 because they are not marked inline and we don't want them to block the
1505 inlining of the parent function. */
1507 static void
1508 check_inlining_for_nested_subprog (tree fndecl)
1510 if (!DECL_DECLARED_INLINE_P (fndecl)
1511 && current_function_decl
1512 && DECL_EXTERNAL (current_function_decl)
1513 && DECL_DECLARED_INLINE_P (current_function_decl))
1515 const location_t loc1 = DECL_SOURCE_LOCATION (fndecl);
1516 const location_t loc2 = DECL_SOURCE_LOCATION (current_function_decl);
1518 if (lookup_attribute ("always_inline",
1519 DECL_ATTRIBUTES (current_function_decl)))
1521 error_at (loc1, "subprogram %q+F not marked Inline_Always", fndecl);
1522 error_at (loc2, "parent subprogram cannot be inlined");
1524 else
1526 warning_at (loc1, OPT_Winline, "subprogram %q+F not marked Inline",
1527 fndecl);
1528 warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined");
1531 DECL_DECLARED_INLINE_P (current_function_decl) = 0;
1532 DECL_UNINLINABLE (current_function_decl) = 1;
1536 /* Return an expression for the length of TYPE, an integral type, computed in
1537 RESULT_TYPE, another integral type.
1539 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1540 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1541 which would only overflow in much rarer cases, for extremely large arrays
1542 we expect never to encounter in practice. Besides, the former computation
1543 required the use of potentially constraining signed arithmetics while the
1544 latter does not. Note that the comparison must be done in the original
1545 base index type in order to avoid any overflow during the conversion. */
1547 static tree
1548 get_type_length (tree type, tree result_type)
1550 tree comp_type = get_base_type (result_type);
1551 tree base_type = get_base_type (type);
1552 tree lb = convert (base_type, TYPE_MIN_VALUE (type));
1553 tree hb = convert (base_type, TYPE_MAX_VALUE (type));
1554 tree length
1555 = build_binary_op (PLUS_EXPR, comp_type,
1556 build_binary_op (MINUS_EXPR, comp_type,
1557 convert (comp_type, hb),
1558 convert (comp_type, lb)),
1559 convert (comp_type, integer_one_node));
1560 length
1561 = build_cond_expr (result_type,
1562 build_binary_op (GE_EXPR, boolean_type_node, hb, lb),
1563 convert (result_type, length),
1564 convert (result_type, integer_zero_node));
1565 return length;
1568 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1569 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1570 where we should place the result type. ATTRIBUTE is the attribute ID. */
1572 static tree
1573 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1575 const Node_Id gnat_prefix = Prefix (gnat_node);
1576 tree gnu_prefix, gnu_type, gnu_expr;
1577 tree gnu_result_type, gnu_result = error_mark_node;
1578 bool prefix_unused = false;
1580 /* ??? If this is an access attribute for a public subprogram to be used in
1581 a dispatch table, do not translate its type as it's useless in this case
1582 and the parameter types might be incomplete types coming from a limited
1583 context in Ada 2012 (AI05-0151). */
1584 if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
1585 && Is_Dispatch_Table_Entity (Etype (gnat_node))
1586 && Nkind (gnat_prefix) == N_Identifier
1587 && Is_Subprogram (Entity (gnat_prefix))
1588 && Is_Public (Entity (gnat_prefix))
1589 && !present_gnu_tree (Entity (gnat_prefix)))
1590 gnu_prefix = get_minimal_subprog_decl (Entity (gnat_prefix));
1591 else
1592 gnu_prefix = gnat_to_gnu (gnat_prefix);
1593 gnu_type = TREE_TYPE (gnu_prefix);
1595 /* If the input is a NULL_EXPR, make a new one. */
1596 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1598 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1599 *gnu_result_type_p = gnu_result_type;
1600 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1603 switch (attribute)
1605 case Attr_Pos:
1606 case Attr_Val:
1607 /* These are just conversions since representation clauses for
1608 enumeration types are handled in the front-end. */
1610 bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1611 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1612 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1613 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1614 checkp, checkp, true, gnat_node);
1616 break;
1618 case Attr_Pred:
1619 case Attr_Succ:
1620 /* These just add or subtract the constant 1 since representation
1621 clauses for enumeration types are handled in the front-end. */
1622 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1623 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1625 if (Do_Range_Check (First (Expressions (gnat_node))))
1627 gnu_expr = gnat_protect_expr (gnu_expr);
1628 gnu_expr
1629 = emit_check
1630 (build_binary_op (EQ_EXPR, boolean_type_node,
1631 gnu_expr,
1632 attribute == Attr_Pred
1633 ? TYPE_MIN_VALUE (gnu_result_type)
1634 : TYPE_MAX_VALUE (gnu_result_type)),
1635 gnu_expr, CE_Range_Check_Failed, gnat_node);
1638 gnu_result
1639 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1640 gnu_result_type, gnu_expr,
1641 convert (gnu_result_type, integer_one_node));
1642 break;
1644 case Attr_Address:
1645 case Attr_Unrestricted_Access:
1646 /* Conversions don't change addresses but can cause us to miss the
1647 COMPONENT_REF case below, so strip them off. */
1648 gnu_prefix = remove_conversions (gnu_prefix,
1649 !Must_Be_Byte_Aligned (gnat_node));
1651 /* If we are taking 'Address of an unconstrained object, this is the
1652 pointer to the underlying array. */
1653 if (attribute == Attr_Address)
1654 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1656 /* If we are building a static dispatch table, we have to honor
1657 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1658 with the C++ ABI. We do it in the non-static case as well,
1659 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1660 else if (TARGET_VTABLE_USES_DESCRIPTORS
1661 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1663 tree gnu_field, t;
1664 /* Descriptors can only be built here for top-level functions. */
1665 bool build_descriptor = (global_bindings_p () != 0);
1666 int i;
1667 vec<constructor_elt, va_gc> *gnu_vec = NULL;
1668 constructor_elt *elt;
1670 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1672 /* If we're not going to build the descriptor, we have to retrieve
1673 the one which will be built by the linker (or by the compiler
1674 later if a static chain is requested). */
1675 if (!build_descriptor)
1677 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1678 gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1679 gnu_result);
1680 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1683 vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS);
1684 elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1685 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1686 i < TARGET_VTABLE_USES_DESCRIPTORS;
1687 gnu_field = DECL_CHAIN (gnu_field), i++)
1689 if (build_descriptor)
1691 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1692 build_int_cst (NULL_TREE, i));
1693 TREE_CONSTANT (t) = 1;
1695 else
1696 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1697 gnu_field, NULL_TREE);
1699 elt->index = gnu_field;
1700 elt->value = t;
1701 elt--;
1704 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1705 break;
1708 /* ... fall through ... */
1710 case Attr_Access:
1711 case Attr_Unchecked_Access:
1712 case Attr_Code_Address:
1713 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1714 gnu_result
1715 = build_unary_op (((attribute == Attr_Address
1716 || attribute == Attr_Unrestricted_Access)
1717 && !Must_Be_Byte_Aligned (gnat_node))
1718 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1719 gnu_result_type, gnu_prefix);
1721 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1722 don't try to build a trampoline. */
1723 if (attribute == Attr_Code_Address)
1725 gnu_expr = remove_conversions (gnu_result, false);
1727 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1728 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1731 /* For 'Access, issue an error message if the prefix is a C++ method
1732 since it can use a special calling convention on some platforms,
1733 which cannot be propagated to the access type. */
1734 else if (attribute == Attr_Access
1735 && Nkind (gnat_prefix) == N_Identifier
1736 && is_cplusplus_method (Entity (gnat_prefix)))
1737 post_error ("access to C++ constructor or member function not allowed",
1738 gnat_node);
1740 /* For other address attributes applied to a nested function,
1741 find an inner ADDR_EXPR and annotate it so that we can issue
1742 a useful warning with -Wtrampolines. */
1743 else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1745 gnu_expr = remove_conversions (gnu_result, false);
1747 if (TREE_CODE (gnu_expr) == ADDR_EXPR
1748 && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1750 set_expr_location_from_node (gnu_expr, gnat_node);
1752 /* Also check the inlining status. */
1753 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
1755 /* Check that we're not violating the No_Implicit_Dynamic_Code
1756 restriction. Be conservative if we don't know anything
1757 about the trampoline strategy for the target. */
1758 Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1761 break;
1763 case Attr_Pool_Address:
1765 tree gnu_ptr = gnu_prefix;
1766 tree gnu_obj_type;
1768 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1770 /* If this is fat pointer, the object must have been allocated with the
1771 template in front of the array. So compute the template address; do
1772 it by converting to a thin pointer. */
1773 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1774 gnu_ptr
1775 = convert (build_pointer_type
1776 (TYPE_OBJECT_RECORD_TYPE
1777 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1778 gnu_ptr);
1780 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1782 /* If this is a thin pointer, the object must have been allocated with
1783 the template in front of the array. So compute the template address
1784 and return it. */
1785 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
1786 gnu_ptr
1787 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
1788 gnu_ptr,
1789 fold_build1 (NEGATE_EXPR, sizetype,
1790 byte_position
1791 (DECL_CHAIN
1792 TYPE_FIELDS ((gnu_obj_type)))));
1794 gnu_result = convert (gnu_result_type, gnu_ptr);
1796 break;
1798 case Attr_Size:
1799 case Attr_Object_Size:
1800 case Attr_Value_Size:
1801 case Attr_Max_Size_In_Storage_Elements:
1802 gnu_expr = gnu_prefix;
1804 /* Remove NOPs and conversions between original and packable version
1805 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
1806 to see if a COMPONENT_REF was involved. */
1807 while (TREE_CODE (gnu_expr) == NOP_EXPR
1808 || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1809 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1810 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1811 == RECORD_TYPE
1812 && TYPE_NAME (TREE_TYPE (gnu_expr))
1813 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1814 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1816 gnu_prefix = remove_conversions (gnu_prefix, true);
1817 prefix_unused = true;
1818 gnu_type = TREE_TYPE (gnu_prefix);
1820 /* Replace an unconstrained array type with the type of the underlying
1821 array. We can't do this with a call to maybe_unconstrained_array
1822 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
1823 use the record type that will be used to allocate the object and its
1824 template. */
1825 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1827 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1828 if (attribute != Attr_Max_Size_In_Storage_Elements)
1829 gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1832 /* If we're looking for the size of a field, return the field size. */
1833 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1834 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1836 /* Otherwise, if the prefix is an object, or if we are looking for
1837 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1838 GCC size of the type. We make an exception for padded objects,
1839 as we do not take into account alignment promotions for the size.
1840 This is in keeping with the object case of gnat_to_gnu_entity. */
1841 else if ((TREE_CODE (gnu_prefix) != TYPE_DECL
1842 && !(TYPE_IS_PADDING_P (gnu_type)
1843 && TREE_CODE (gnu_expr) == COMPONENT_REF))
1844 || attribute == Attr_Object_Size
1845 || attribute == Attr_Max_Size_In_Storage_Elements)
1847 /* If this is a dereference and we have a special dynamic constrained
1848 subtype on the prefix, use it to compute the size; otherwise, use
1849 the designated subtype. */
1850 if (Nkind (gnat_prefix) == N_Explicit_Dereference)
1852 Node_Id gnat_actual_subtype
1853 = Actual_Designated_Subtype (gnat_prefix);
1854 tree gnu_ptr_type
1855 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
1857 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1858 && Present (gnat_actual_subtype))
1860 tree gnu_actual_obj_type
1861 = gnat_to_gnu_type (gnat_actual_subtype);
1862 gnu_type
1863 = build_unc_object_type_from_ptr (gnu_ptr_type,
1864 gnu_actual_obj_type,
1865 get_identifier ("SIZE"),
1866 false);
1870 gnu_result = TYPE_SIZE (gnu_type);
1873 /* Otherwise, the result is the RM size of the type. */
1874 else
1875 gnu_result = rm_size (gnu_type);
1877 /* Deal with a self-referential size by returning the maximum size for
1878 a type and by qualifying the size with the object otherwise. */
1879 if (CONTAINS_PLACEHOLDER_P (gnu_result))
1881 if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1882 gnu_result = max_size (gnu_result, true);
1883 else
1884 gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1887 /* If the type contains a template, subtract its size. */
1888 if (TREE_CODE (gnu_type) == RECORD_TYPE
1889 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1890 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1891 DECL_SIZE (TYPE_FIELDS (gnu_type)));
1893 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
1894 if (attribute == Attr_Max_Size_In_Storage_Elements)
1895 gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1897 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1898 break;
1900 case Attr_Alignment:
1902 unsigned int align;
1904 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1905 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1906 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1908 gnu_type = TREE_TYPE (gnu_prefix);
1909 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1910 prefix_unused = true;
1912 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1913 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1914 else
1916 Entity_Id gnat_type = Etype (gnat_prefix);
1917 unsigned int double_align;
1918 bool is_capped_double, align_clause;
1920 /* If the default alignment of "double" or larger scalar types is
1921 specifically capped and there is an alignment clause neither
1922 on the type nor on the prefix itself, return the cap. */
1923 if ((double_align = double_float_alignment) > 0)
1924 is_capped_double
1925 = is_double_float_or_array (gnat_type, &align_clause);
1926 else if ((double_align = double_scalar_alignment) > 0)
1927 is_capped_double
1928 = is_double_scalar_or_array (gnat_type, &align_clause);
1929 else
1930 is_capped_double = align_clause = false;
1932 if (is_capped_double
1933 && Nkind (gnat_prefix) == N_Identifier
1934 && Present (Alignment_Clause (Entity (gnat_prefix))))
1935 align_clause = true;
1937 if (is_capped_double && !align_clause)
1938 align = double_align;
1939 else
1940 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1943 gnu_result = size_int (align);
1945 break;
1947 case Attr_First:
1948 case Attr_Last:
1949 case Attr_Range_Length:
1950 prefix_unused = true;
1952 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1954 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1956 if (attribute == Attr_First)
1957 gnu_result = TYPE_MIN_VALUE (gnu_type);
1958 else if (attribute == Attr_Last)
1959 gnu_result = TYPE_MAX_VALUE (gnu_type);
1960 else
1961 gnu_result = get_type_length (gnu_type, gnu_result_type);
1962 break;
1965 /* ... fall through ... */
1967 case Attr_Length:
1969 int Dimension = (Present (Expressions (gnat_node))
1970 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1971 : 1), i;
1972 struct parm_attr_d *pa = NULL;
1973 Entity_Id gnat_param = Empty;
1974 bool unconstrained_ptr_deref = false;
1976 /* Make sure any implicit dereference gets done. */
1977 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1978 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1980 /* We treat unconstrained array In parameters specially. We also note
1981 whether we are dereferencing a pointer to unconstrained array. */
1982 if (!Is_Constrained (Etype (gnat_prefix)))
1983 switch (Nkind (gnat_prefix))
1985 case N_Identifier:
1986 /* This is the direct case. */
1987 if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
1988 gnat_param = Entity (gnat_prefix);
1989 break;
1991 case N_Explicit_Dereference:
1992 /* This is the indirect case. Note that we need to be sure that
1993 the access value cannot be null as we'll hoist the load. */
1994 if (Nkind (Prefix (gnat_prefix)) == N_Identifier
1995 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
1997 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
1998 gnat_param = Entity (Prefix (gnat_prefix));
2000 else
2001 unconstrained_ptr_deref = true;
2002 break;
2004 default:
2005 break;
2008 /* If the prefix is the view conversion of a constrained array to an
2009 unconstrained form, we retrieve the constrained array because we
2010 might not be able to substitute the PLACEHOLDER_EXPR coming from
2011 the conversion. This can occur with the 'Old attribute applied
2012 to a parameter with an unconstrained type, which gets rewritten
2013 into a constrained local variable very late in the game. */
2014 if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
2015 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix)))
2016 && !CONTAINS_PLACEHOLDER_P
2017 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
2018 gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0));
2019 else
2020 gnu_type = TREE_TYPE (gnu_prefix);
2022 prefix_unused = true;
2023 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2025 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
2027 int ndim;
2028 tree gnu_type_temp;
2030 for (ndim = 1, gnu_type_temp = gnu_type;
2031 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
2032 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
2033 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
2036 Dimension = ndim + 1 - Dimension;
2039 for (i = 1; i < Dimension; i++)
2040 gnu_type = TREE_TYPE (gnu_type);
2042 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2044 /* When not optimizing, look up the slot associated with the parameter
2045 and the dimension in the cache and create a new one on failure.
2046 Don't do this when the actual subtype needs debug info (this happens
2047 with -gnatD): in elaborate_expression_1, we create variables that
2048 hold the bounds, so caching attributes isn't very interesting and
2049 causes dependency issues between these variables and cached
2050 expressions. */
2051 if (!optimize
2052 && Present (gnat_param)
2053 && !(Present (Actual_Subtype (gnat_param))
2054 && Needs_Debug_Info (Actual_Subtype (gnat_param))))
2056 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa)
2057 if (pa->id == gnat_param && pa->dim == Dimension)
2058 break;
2060 if (!pa)
2062 pa = ggc_cleared_alloc<parm_attr_d> ();
2063 pa->id = gnat_param;
2064 pa->dim = Dimension;
2065 vec_safe_push (f_parm_attr_cache, pa);
2069 /* Return the cached expression or build a new one. */
2070 if (attribute == Attr_First)
2072 if (pa && pa->first)
2074 gnu_result = pa->first;
2075 break;
2078 gnu_result
2079 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2082 else if (attribute == Attr_Last)
2084 if (pa && pa->last)
2086 gnu_result = pa->last;
2087 break;
2090 gnu_result
2091 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2094 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2096 if (pa && pa->length)
2098 gnu_result = pa->length;
2099 break;
2102 gnu_result
2103 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)),
2104 gnu_result_type);
2107 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2108 handling. Note that these attributes could not have been used on
2109 an unconstrained array type. */
2110 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2112 /* Cache the expression we have just computed. Since we want to do it
2113 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2114 create the temporary in the outermost binding level. We will make
2115 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2116 paths by forcing its evaluation on entry of the function. */
2117 if (pa)
2119 gnu_result
2120 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2121 switch (attribute)
2123 case Attr_First:
2124 pa->first = gnu_result;
2125 break;
2127 case Attr_Last:
2128 pa->last = gnu_result;
2129 break;
2131 case Attr_Length:
2132 case Attr_Range_Length:
2133 pa->length = gnu_result;
2134 break;
2136 default:
2137 gcc_unreachable ();
2141 /* Otherwise, evaluate it each time it is referenced. */
2142 else
2143 switch (attribute)
2145 case Attr_First:
2146 case Attr_Last:
2147 /* If we are dereferencing a pointer to unconstrained array, we
2148 need to capture the value because the pointed-to bounds may
2149 subsequently be released. */
2150 if (unconstrained_ptr_deref)
2151 gnu_result
2152 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2153 break;
2155 case Attr_Length:
2156 case Attr_Range_Length:
2157 /* Set the source location onto the predicate of the condition
2158 but not if the expression is cached to avoid messing up the
2159 debug info. */
2160 if (TREE_CODE (gnu_result) == COND_EXPR
2161 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
2162 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
2163 gnat_node);
2164 break;
2166 default:
2167 gcc_unreachable ();
2170 break;
2173 case Attr_Bit_Position:
2174 case Attr_Position:
2175 case Attr_First_Bit:
2176 case Attr_Last_Bit:
2177 case Attr_Bit:
2179 HOST_WIDE_INT bitsize;
2180 HOST_WIDE_INT bitpos;
2181 tree gnu_offset;
2182 tree gnu_field_bitpos;
2183 tree gnu_field_offset;
2184 tree gnu_inner;
2185 machine_mode mode;
2186 int unsignedp, reversep, volatilep;
2188 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2189 gnu_prefix = remove_conversions (gnu_prefix, true);
2190 prefix_unused = true;
2192 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2193 the result is 0. Don't allow 'Bit on a bare component, though. */
2194 if (attribute == Attr_Bit
2195 && TREE_CODE (gnu_prefix) != COMPONENT_REF
2196 && TREE_CODE (gnu_prefix) != FIELD_DECL)
2198 gnu_result = integer_zero_node;
2199 break;
2202 else
2203 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
2204 || (attribute == Attr_Bit_Position
2205 && TREE_CODE (gnu_prefix) == FIELD_DECL));
2207 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
2208 &mode, &unsignedp, &reversep, &volatilep, false);
2210 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2212 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
2213 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
2215 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
2216 TREE_CODE (gnu_inner) == COMPONENT_REF
2217 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
2218 gnu_inner = TREE_OPERAND (gnu_inner, 0))
2220 gnu_field_bitpos
2221 = size_binop (PLUS_EXPR, gnu_field_bitpos,
2222 bit_position (TREE_OPERAND (gnu_inner, 1)));
2223 gnu_field_offset
2224 = size_binop (PLUS_EXPR, gnu_field_offset,
2225 byte_position (TREE_OPERAND (gnu_inner, 1)));
2228 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
2230 gnu_field_bitpos = bit_position (gnu_prefix);
2231 gnu_field_offset = byte_position (gnu_prefix);
2233 else
2235 gnu_field_bitpos = bitsize_zero_node;
2236 gnu_field_offset = size_zero_node;
2239 switch (attribute)
2241 case Attr_Position:
2242 gnu_result = gnu_field_offset;
2243 break;
2245 case Attr_First_Bit:
2246 case Attr_Bit:
2247 gnu_result = size_int (bitpos % BITS_PER_UNIT);
2248 break;
2250 case Attr_Last_Bit:
2251 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
2252 gnu_result = size_binop (PLUS_EXPR, gnu_result,
2253 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
2254 /* ??? Avoid a large unsigned result that will overflow when
2255 converted to the signed universal_integer. */
2256 if (integer_zerop (gnu_result))
2257 gnu_result = integer_minus_one_node;
2258 else
2259 gnu_result
2260 = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node);
2261 break;
2263 case Attr_Bit_Position:
2264 gnu_result = gnu_field_bitpos;
2265 break;
2268 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2269 handling. */
2270 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2271 break;
2274 case Attr_Min:
2275 case Attr_Max:
2277 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
2278 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
2280 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2282 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2283 a NaN so we implement the semantics of C99 f{min,max} to make it
2284 predictable in this case: if either operand is a NaN, the other
2285 is returned; if both operands are NaN's, a NaN is returned. */
2286 if (SCALAR_FLOAT_TYPE_P (gnu_result_type)
2287 && !Machine_Overflows_On_Target)
2289 const bool lhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_lhs);
2290 const bool rhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_rhs);
2291 tree t = builtin_decl_explicit (BUILT_IN_ISNAN);
2292 tree lhs_is_nan, rhs_is_nan;
2294 /* If the operands have side-effects, they need to be evaluated
2295 only once in spite of the multiple references in the result. */
2296 if (lhs_side_effects_p)
2297 gnu_lhs = gnat_protect_expr (gnu_lhs);
2298 if (rhs_side_effects_p)
2299 gnu_rhs = gnat_protect_expr (gnu_rhs);
2301 lhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2302 build_call_expr (t, 1, gnu_lhs),
2303 integer_zero_node);
2305 rhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2306 build_call_expr (t, 1, gnu_rhs),
2307 integer_zero_node);
2309 gnu_result = build_binary_op (attribute == Attr_Min
2310 ? MIN_EXPR : MAX_EXPR,
2311 gnu_result_type, gnu_lhs, gnu_rhs);
2312 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2313 rhs_is_nan, gnu_lhs, gnu_result);
2314 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2315 lhs_is_nan, gnu_rhs, gnu_result);
2317 /* If the operands have side-effects, they need to be evaluated
2318 before doing the tests above since the place they otherwise
2319 would end up being evaluated at run time could be wrong. */
2320 if (lhs_side_effects_p)
2321 gnu_result
2322 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_lhs, gnu_result);
2324 if (rhs_side_effects_p)
2325 gnu_result
2326 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_rhs, gnu_result);
2328 else
2329 gnu_result = build_binary_op (attribute == Attr_Min
2330 ? MIN_EXPR : MAX_EXPR,
2331 gnu_result_type, gnu_lhs, gnu_rhs);
2333 break;
2335 case Attr_Passed_By_Reference:
2336 gnu_result = size_int (default_pass_by_ref (gnu_type)
2337 || must_pass_by_ref (gnu_type));
2338 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2339 break;
2341 case Attr_Component_Size:
2342 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
2343 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
2344 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
2346 gnu_prefix = maybe_implicit_deref (gnu_prefix);
2347 gnu_type = TREE_TYPE (gnu_prefix);
2349 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2350 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
2352 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2353 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
2354 gnu_type = TREE_TYPE (gnu_type);
2356 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2358 /* Note this size cannot be self-referential. */
2359 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
2360 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2361 prefix_unused = true;
2362 break;
2364 case Attr_Descriptor_Size:
2365 gnu_type = TREE_TYPE (gnu_prefix);
2366 gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
2368 /* What we want is the offset of the ARRAY field in the record
2369 that the thin pointer designates. */
2370 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
2371 gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
2372 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2373 prefix_unused = true;
2374 break;
2376 case Attr_Null_Parameter:
2377 /* This is just a zero cast to the pointer type for our prefix and
2378 dereferenced. */
2379 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2380 gnu_result
2381 = build_unary_op (INDIRECT_REF, NULL_TREE,
2382 convert (build_pointer_type (gnu_result_type),
2383 integer_zero_node));
2384 TREE_PRIVATE (gnu_result) = 1;
2385 break;
2387 case Attr_Mechanism_Code:
2389 Entity_Id gnat_obj = Entity (gnat_prefix);
2390 int code;
2392 prefix_unused = true;
2393 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2394 if (Present (Expressions (gnat_node)))
2396 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
2398 for (gnat_obj = First_Formal (gnat_obj); i > 1;
2399 i--, gnat_obj = Next_Formal (gnat_obj))
2403 code = Mechanism (gnat_obj);
2404 if (code == Default)
2405 code = ((present_gnu_tree (gnat_obj)
2406 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
2407 || ((TREE_CODE (get_gnu_tree (gnat_obj))
2408 == PARM_DECL)
2409 && (DECL_BY_COMPONENT_PTR_P
2410 (get_gnu_tree (gnat_obj))))))
2411 ? By_Reference : By_Copy);
2412 gnu_result = convert (gnu_result_type, size_int (- code));
2414 break;
2416 case Attr_Model:
2417 /* We treat Model as identical to Machine. This is true for at least
2418 IEEE and some other nice floating-point systems. */
2420 /* ... fall through ... */
2422 case Attr_Machine:
2423 /* The trick is to force the compiler to store the result in memory so
2424 that we do not have extra precision used. But do this only when this
2425 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2426 the type is lower than that of the longest floating-point type. */
2427 prefix_unused = true;
2428 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2429 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2430 gnu_result = convert (gnu_result_type, gnu_expr);
2432 if (TREE_CODE (gnu_result) != REAL_CST
2433 && fp_arith_may_widen
2434 && TYPE_PRECISION (gnu_result_type)
2435 < TYPE_PRECISION (longest_float_type_node))
2437 tree rec_type = make_node (RECORD_TYPE);
2438 tree field
2439 = create_field_decl (get_identifier ("OBJ"), gnu_result_type,
2440 rec_type, NULL_TREE, NULL_TREE, 0, 0);
2441 tree rec_val, asm_expr;
2443 finish_record_type (rec_type, field, 0, false);
2445 rec_val = build_constructor_single (rec_type, field, gnu_result);
2446 rec_val = build1 (SAVE_EXPR, rec_type, rec_val);
2448 asm_expr
2449 = build5 (ASM_EXPR, void_type_node,
2450 build_string (0, ""),
2451 tree_cons (build_tree_list (NULL_TREE,
2452 build_string (2, "=m")),
2453 rec_val, NULL_TREE),
2454 tree_cons (build_tree_list (NULL_TREE,
2455 build_string (1, "m")),
2456 rec_val, NULL_TREE),
2457 NULL_TREE, NULL_TREE);
2458 ASM_VOLATILE_P (asm_expr) = 1;
2460 gnu_result
2461 = build_compound_expr (gnu_result_type, asm_expr,
2462 build_component_ref (rec_val, field,
2463 false));
2465 break;
2467 case Attr_Deref:
2468 prefix_unused = true;
2469 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2470 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2471 /* This can be a random address so build an alias-all pointer type. */
2472 gnu_expr
2473 = convert (build_pointer_type_for_mode (gnu_result_type, ptr_mode,
2474 true),
2475 gnu_expr);
2476 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_expr);
2477 break;
2479 default:
2480 /* This abort means that we have an unimplemented attribute. */
2481 gcc_unreachable ();
2484 /* If this is an attribute where the prefix was unused, force a use of it if
2485 it has a side-effect. But don't do it if the prefix is just an entity
2486 name. However, if an access check is needed, we must do it. See second
2487 example in AARM 11.6(5.e). */
2488 if (prefix_unused
2489 && TREE_SIDE_EFFECTS (gnu_prefix)
2490 && !Is_Entity_Name (gnat_prefix))
2491 gnu_result
2492 = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
2494 *gnu_result_type_p = gnu_result_type;
2495 return gnu_result;
2498 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2499 to a GCC tree, which is returned. */
2501 static tree
2502 Case_Statement_to_gnu (Node_Id gnat_node)
2504 tree gnu_result, gnu_expr, gnu_label;
2505 Node_Id gnat_when;
2506 location_t end_locus;
2507 bool may_fallthru = false;
2509 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2510 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2512 /* The range of values in a case statement is determined by the rules in
2513 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
2514 of the expression. One exception arises in the case of a simple name that
2515 is parenthesized. This still has the Etype of the name, but since it is
2516 not a name, para 7 does not apply, and we need to go to the base type.
2517 This is the only case where parenthesization affects the dynamic
2518 semantics (i.e. the range of possible values at run time that is covered
2519 by the others alternative).
2521 Another exception is if the subtype of the expression is non-static. In
2522 that case, we also have to use the base type. */
2523 if (Paren_Count (Expression (gnat_node)) != 0
2524 || !Is_OK_Static_Subtype (Underlying_Type
2525 (Etype (Expression (gnat_node)))))
2526 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2528 /* We build a SWITCH_EXPR that contains the code with interspersed
2529 CASE_LABEL_EXPRs for each label. */
2530 if (!Sloc_to_locus (End_Location (gnat_node), &end_locus))
2531 end_locus = input_location;
2532 gnu_label = create_artificial_label (end_locus);
2533 start_stmt_group ();
2535 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2536 Present (gnat_when);
2537 gnat_when = Next_Non_Pragma (gnat_when))
2539 bool choices_added_p = false;
2540 Node_Id gnat_choice;
2542 /* First compile all the different case choices for the current WHEN
2543 alternative. */
2544 for (gnat_choice = First (Discrete_Choices (gnat_when));
2545 Present (gnat_choice);
2546 gnat_choice = Next (gnat_choice))
2548 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2549 tree label = create_artificial_label (input_location);
2551 switch (Nkind (gnat_choice))
2553 case N_Range:
2554 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2555 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2556 break;
2558 case N_Subtype_Indication:
2559 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2560 (Constraint (gnat_choice))));
2561 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2562 (Constraint (gnat_choice))));
2563 break;
2565 case N_Identifier:
2566 case N_Expanded_Name:
2567 /* This represents either a subtype range or a static value of
2568 some kind; Ekind says which. */
2569 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2571 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2573 gnu_low = TYPE_MIN_VALUE (gnu_type);
2574 gnu_high = TYPE_MAX_VALUE (gnu_type);
2575 break;
2578 /* ... fall through ... */
2580 case N_Character_Literal:
2581 case N_Integer_Literal:
2582 gnu_low = gnat_to_gnu (gnat_choice);
2583 break;
2585 case N_Others_Choice:
2586 break;
2588 default:
2589 gcc_unreachable ();
2592 /* Everything should be folded into constants at this point. */
2593 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
2594 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
2596 add_stmt_with_node (build_case_label (gnu_low, gnu_high, label),
2597 gnat_choice);
2598 choices_added_p = true;
2601 /* This construct doesn't define a scope so we shouldn't push a binding
2602 level around the statement list. Except that we have always done so
2603 historically and this makes it possible to reduce stack usage. As a
2604 compromise, we keep doing it for case statements, for which this has
2605 never been problematic, but not for case expressions in Ada 2012. */
2606 if (choices_added_p)
2608 const bool is_case_expression
2609 = (Nkind (Parent (gnat_node)) == N_Expression_With_Actions);
2610 tree group
2611 = build_stmt_group (Statements (gnat_when), !is_case_expression);
2612 bool group_may_fallthru = block_may_fallthru (group);
2613 add_stmt (group);
2614 if (group_may_fallthru)
2616 tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2617 SET_EXPR_LOCATION (stmt, end_locus);
2618 add_stmt (stmt);
2619 may_fallthru = true;
2624 /* Now emit a definition of the label the cases branch to, if any. */
2625 if (may_fallthru)
2626 add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2627 gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2628 end_stmt_group (), NULL_TREE);
2630 return gnu_result;
2633 /* Return true if we are in the body of a loop. */
2635 static inline bool
2636 inside_loop_p (void)
2638 return !vec_safe_is_empty (gnu_loop_stack);
2641 /* Find out whether VAR is the iteration variable of an enclosing loop in the
2642 current function. If so, return the loop; otherwise, return NULL. */
2644 static struct loop_info_d *
2645 find_loop_for (tree var)
2647 struct loop_info_d *iter = NULL;
2648 unsigned int i;
2650 var = remove_conversions (var, false);
2652 if (TREE_CODE (var) != VAR_DECL)
2653 return NULL;
2655 if (decl_function_context (var) != current_function_decl)
2656 return NULL;
2658 gcc_assert (vec_safe_length (gnu_loop_stack) > 0);
2660 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
2661 if (var == iter->loop_var)
2662 break;
2664 return iter;
2667 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2668 false, or the maximum value if MAX is true, of TYPE. */
2670 static bool
2671 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2673 tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2675 if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2676 return true;
2678 if (TREE_CODE (val) == NOP_EXPR)
2679 val = (max
2680 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2681 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2683 if (TREE_CODE (val) != INTEGER_CST)
2684 return true;
2686 if (max)
2687 return tree_int_cst_lt (val, min_or_max_val) == 0;
2688 else
2689 return tree_int_cst_lt (min_or_max_val, val) == 0;
2692 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2693 If REVERSE is true, minimum value is taken as maximum value. */
2695 static inline bool
2696 can_equal_min_val_p (tree val, tree type, bool reverse)
2698 return can_equal_min_or_max_val_p (val, type, reverse);
2701 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2702 If REVERSE is true, maximum value is taken as minimum value. */
2704 static inline bool
2705 can_equal_max_val_p (tree val, tree type, bool reverse)
2707 return can_equal_min_or_max_val_p (val, type, !reverse);
2710 /* Return true if VAL1 can be lower than VAL2. */
2712 static bool
2713 can_be_lower_p (tree val1, tree val2)
2715 if (TREE_CODE (val1) == NOP_EXPR)
2716 val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2718 if (TREE_CODE (val1) != INTEGER_CST)
2719 return true;
2721 if (TREE_CODE (val2) == NOP_EXPR)
2722 val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2724 if (TREE_CODE (val2) != INTEGER_CST)
2725 return true;
2727 return tree_int_cst_lt (val1, val2);
2730 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
2731 true if both expressions have been replaced and false otherwise. */
2733 static bool
2734 make_invariant (tree *expr1, tree *expr2)
2736 tree inv_expr1 = gnat_invariant_expr (*expr1);
2737 tree inv_expr2 = gnat_invariant_expr (*expr2);
2739 if (inv_expr1)
2740 *expr1 = inv_expr1;
2742 if (inv_expr2)
2743 *expr2 = inv_expr2;
2745 return inv_expr1 && inv_expr2;
2748 /* Helper function for walk_tree, used by independent_iterations_p below. */
2750 static tree
2751 scan_rhs_r (tree *tp, int *walk_subtrees, void *data)
2753 bitmap *params = (bitmap *)data;
2754 tree t = *tp;
2756 /* No need to walk into types or decls. */
2757 if (IS_TYPE_OR_DECL_P (t))
2758 *walk_subtrees = 0;
2760 if (TREE_CODE (t) == PARM_DECL && bitmap_bit_p (*params, DECL_UID (t)))
2761 return t;
2763 return NULL_TREE;
2766 /* Return true if STMT_LIST generates independent iterations in a loop. */
2768 static bool
2769 independent_iterations_p (tree stmt_list)
2771 tree_stmt_iterator tsi;
2772 bitmap params = BITMAP_GGC_ALLOC();
2773 auto_vec<tree> rhs;
2774 tree iter;
2775 int i;
2777 if (TREE_CODE (stmt_list) == BIND_EXPR)
2778 stmt_list = BIND_EXPR_BODY (stmt_list);
2780 /* Scan the list and return false on anything that is not either a check
2781 or an assignment to a parameter with restricted aliasing. */
2782 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
2784 tree stmt = tsi_stmt (tsi);
2786 switch (TREE_CODE (stmt))
2788 case COND_EXPR:
2790 if (COND_EXPR_ELSE (stmt))
2791 return false;
2792 if (TREE_CODE (COND_EXPR_THEN (stmt)) != CALL_EXPR)
2793 return false;
2794 tree func = get_callee_fndecl (COND_EXPR_THEN (stmt));
2795 if (!(func && TREE_THIS_VOLATILE (func)))
2796 return false;
2797 break;
2800 case MODIFY_EXPR:
2802 tree lhs = TREE_OPERAND (stmt, 0);
2803 while (handled_component_p (lhs))
2804 lhs = TREE_OPERAND (lhs, 0);
2805 if (TREE_CODE (lhs) != INDIRECT_REF)
2806 return false;
2807 lhs = TREE_OPERAND (lhs, 0);
2808 if (!(TREE_CODE (lhs) == PARM_DECL
2809 && DECL_RESTRICTED_ALIASING_P (lhs)))
2810 return false;
2811 bitmap_set_bit (params, DECL_UID (lhs));
2812 rhs.safe_push (TREE_OPERAND (stmt, 1));
2813 break;
2816 default:
2817 return false;
2821 /* At this point we know that the list contains only statements that will
2822 modify parameters with restricted aliasing. Check that the statements
2823 don't at the time read from these parameters. */
2824 FOR_EACH_VEC_ELT (rhs, i, iter)
2825 if (walk_tree_without_duplicates (&iter, scan_rhs_r, &params))
2826 return false;
2828 return true;
2831 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2832 to a GCC tree, which is returned. */
2834 static tree
2835 Loop_Statement_to_gnu (Node_Id gnat_node)
2837 const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2838 struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
2839 tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2840 NULL_TREE, NULL_TREE, NULL_TREE);
2841 tree gnu_loop_label = create_artificial_label (input_location);
2842 tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2843 tree gnu_result;
2845 /* Push the loop_info structure associated with the LOOP_STMT. */
2846 vec_safe_push (gnu_loop_stack, gnu_loop_info);
2848 /* Set location information for statement and end label. */
2849 set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2850 Sloc_to_locus (Sloc (End_Label (gnat_node)),
2851 &DECL_SOURCE_LOCATION (gnu_loop_label));
2852 LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2854 /* Save the statement for later reuse. */
2855 gnu_loop_info->stmt = gnu_loop_stmt;
2856 gnu_loop_info->artificial = !Comes_From_Source (gnat_node);
2858 /* Set the condition under which the loop must keep going.
2859 For the case "LOOP .... END LOOP;" the condition is always true. */
2860 if (No (gnat_iter_scheme))
2863 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2864 else if (Present (Condition (gnat_iter_scheme)))
2865 LOOP_STMT_COND (gnu_loop_stmt)
2866 = gnat_to_gnu (Condition (gnat_iter_scheme));
2868 /* Otherwise we have an iteration scheme and the condition is given by the
2869 bounds of the subtype of the iteration variable. */
2870 else
2872 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2873 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2874 Entity_Id gnat_type = Etype (gnat_loop_var);
2875 tree gnu_type = get_unpadded_type (gnat_type);
2876 tree gnu_base_type = get_base_type (gnu_type);
2877 tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2878 tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2879 enum tree_code update_code, test_code, shift_code;
2880 bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2882 gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type));
2883 gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type));
2885 /* We must disable modulo reduction for the iteration variable, if any,
2886 in order for the loop comparison to be effective. */
2887 if (reverse)
2889 gnu_first = gnu_high;
2890 gnu_last = gnu_low;
2891 update_code = MINUS_NOMOD_EXPR;
2892 test_code = GE_EXPR;
2893 shift_code = PLUS_NOMOD_EXPR;
2895 else
2897 gnu_first = gnu_low;
2898 gnu_last = gnu_high;
2899 update_code = PLUS_NOMOD_EXPR;
2900 test_code = LE_EXPR;
2901 shift_code = MINUS_NOMOD_EXPR;
2904 /* We use two different strategies to translate the loop, depending on
2905 whether optimization is enabled.
2907 If it is, we generate the canonical loop form expected by the loop
2908 optimizer and the loop vectorizer, which is the do-while form:
2910 ENTRY_COND
2911 loop:
2912 TOP_UPDATE
2913 BODY
2914 BOTTOM_COND
2915 GOTO loop
2917 This avoids an implicit dependency on loop header copying and makes
2918 it possible to turn BOTTOM_COND into an inequality test.
2920 If optimization is disabled, loop header copying doesn't come into
2921 play and we try to generate the loop form with the fewer conditional
2922 branches. First, the default form, which is:
2924 loop:
2925 TOP_COND
2926 BODY
2927 BOTTOM_UPDATE
2928 GOTO loop
2930 It should catch most loops with constant ending point. Then, if we
2931 cannot, we try to generate the shifted form:
2933 loop:
2934 TOP_COND
2935 TOP_UPDATE
2936 BODY
2937 GOTO loop
2939 which should catch loops with constant starting point. Otherwise, if
2940 we cannot, we generate the fallback form:
2942 ENTRY_COND
2943 loop:
2944 BODY
2945 BOTTOM_COND
2946 BOTTOM_UPDATE
2947 GOTO loop
2949 which works in all cases. */
2951 if (optimize)
2953 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
2954 overflow. */
2955 if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2958 /* Otherwise, use the do-while form with the help of a special
2959 induction variable in the unsigned version of the base type
2960 or the unsigned version of the size type, whichever is the
2961 largest, in order to have wrap-around arithmetics for it. */
2962 else
2964 if (TYPE_PRECISION (gnu_base_type)
2965 > TYPE_PRECISION (size_type_node))
2966 gnu_base_type
2967 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1);
2968 else
2969 gnu_base_type = size_type_node;
2971 gnu_first = convert (gnu_base_type, gnu_first);
2972 gnu_last = convert (gnu_base_type, gnu_last);
2973 gnu_one_node = convert (gnu_base_type, integer_one_node);
2974 use_iv = true;
2977 gnu_first
2978 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2979 gnu_one_node);
2980 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2981 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2983 else
2985 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
2986 if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2989 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2990 GNU_LAST-1 does. */
2991 else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2992 && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2994 gnu_first
2995 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2996 gnu_one_node);
2997 gnu_last
2998 = build_binary_op (shift_code, gnu_base_type, gnu_last,
2999 gnu_one_node);
3000 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
3003 /* Otherwise, use the fallback form. */
3004 else
3005 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3008 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3009 test but we may have to add ENTRY_COND to protect the empty loop. */
3010 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
3012 test_code = NE_EXPR;
3013 if (can_be_lower_p (gnu_high, gnu_low))
3015 gnu_cond_expr
3016 = build3 (COND_EXPR, void_type_node,
3017 build_binary_op (LE_EXPR, boolean_type_node,
3018 gnu_low, gnu_high),
3019 NULL_TREE, alloc_stmt_list ());
3020 set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
3024 /* Open a new nesting level that will surround the loop to declare the
3025 iteration variable. */
3026 start_stmt_group ();
3027 gnat_pushlevel ();
3029 /* If we use the special induction variable, create it and set it to
3030 its initial value. Morever, the regular iteration variable cannot
3031 itself be initialized, lest the initial value wrapped around. */
3032 if (use_iv)
3034 gnu_loop_iv
3035 = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
3036 add_stmt (gnu_stmt);
3037 gnu_first = NULL_TREE;
3039 else
3040 gnu_loop_iv = NULL_TREE;
3042 /* Declare the iteration variable and set it to its initial value. */
3043 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
3044 if (DECL_BY_REF_P (gnu_loop_var))
3045 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
3046 else if (use_iv)
3048 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
3049 SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
3051 gnu_loop_info->loop_var = gnu_loop_var;
3052 gnu_loop_info->low_bound = gnu_low;
3053 gnu_loop_info->high_bound = gnu_high;
3055 /* Do all the arithmetics in the base type. */
3056 gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
3058 /* Set either the top or bottom exit condition. */
3059 if (use_iv)
3060 LOOP_STMT_COND (gnu_loop_stmt)
3061 = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
3062 gnu_last);
3063 else
3064 LOOP_STMT_COND (gnu_loop_stmt)
3065 = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
3066 gnu_last);
3068 /* Set either the top or bottom update statement and give it the source
3069 location of the iteration for better coverage info. */
3070 if (use_iv)
3072 gnu_stmt
3073 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
3074 build_binary_op (update_code, gnu_base_type,
3075 gnu_loop_iv, gnu_one_node));
3076 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3077 append_to_statement_list (gnu_stmt,
3078 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3079 gnu_stmt
3080 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3081 gnu_loop_iv);
3082 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3083 append_to_statement_list (gnu_stmt,
3084 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3086 else
3088 gnu_stmt
3089 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3090 build_binary_op (update_code, gnu_base_type,
3091 gnu_loop_var, gnu_one_node));
3092 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3093 LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
3097 /* If the loop was named, have the name point to this loop. In this case,
3098 the association is not a DECL node, but the end label of the loop. */
3099 if (Present (Identifier (gnat_node)))
3100 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
3102 /* Make the loop body into its own block, so any allocated storage will be
3103 released every iteration. This is needed for stack allocation. */
3104 LOOP_STMT_BODY (gnu_loop_stmt)
3105 = build_stmt_group (Statements (gnat_node), true);
3106 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
3108 /* If we have an iteration scheme, then we are in a statement group. Add
3109 the LOOP_STMT to it, finish it and make it the "loop". */
3110 if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
3112 /* First, if we have computed invariant conditions for range (or index)
3113 checks applied to the iteration variable, find out whether they can
3114 be evaluated to false at compile time; otherwise, if there are not
3115 too many of them, combine them with the original checks. If loop
3116 unswitching is enabled, do not require the loop bounds to be also
3117 invariant, as their evaluation will still be ahead of the loop. */
3118 if (vec_safe_length (gnu_loop_info->checks) > 0
3119 && (make_invariant (&gnu_low, &gnu_high) || flag_unswitch_loops))
3121 struct range_check_info_d *rci;
3122 unsigned int i, n_remaining_checks = 0;
3124 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3126 tree low_ok
3127 = rci->low_bound
3128 ? build_binary_op (GE_EXPR, boolean_type_node,
3129 convert (rci->type, gnu_low),
3130 rci->low_bound)
3131 : boolean_true_node;
3133 tree high_ok
3134 = rci->high_bound
3135 ? build_binary_op (LE_EXPR, boolean_type_node,
3136 convert (rci->type, gnu_high),
3137 rci->high_bound)
3138 : boolean_true_node;
3140 tree range_ok
3141 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
3142 low_ok, high_ok);
3144 rci->invariant_cond
3145 = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
3147 if (rci->invariant_cond == boolean_false_node)
3148 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3149 else
3150 n_remaining_checks++;
3153 /* Note that loop unswitching can only be applied a small number of
3154 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3155 if (0 < n_remaining_checks && n_remaining_checks <= 3
3156 && optimize > 1 && !optimize_size)
3157 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3158 if (rci->invariant_cond != boolean_false_node)
3160 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3162 if (flag_unswitch_loops)
3163 add_stmt_with_node_force (rci->inserted_cond, gnat_node);
3167 /* Second, if loop vectorization is enabled and the iterations of the
3168 loop can easily be proved as independent, mark the loop. */
3169 if (optimize
3170 && flag_tree_loop_vectorize
3171 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt)))
3172 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
3174 add_stmt (gnu_loop_stmt);
3175 gnat_poplevel ();
3176 gnu_loop_stmt = end_stmt_group ();
3179 /* If we have an outer COND_EXPR, that's our result and this loop is its
3180 "true" statement. Otherwise, the result is the LOOP_STMT. */
3181 if (gnu_cond_expr)
3183 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
3184 TREE_SIDE_EFFECTS (gnu_cond_expr) = 1;
3185 gnu_result = gnu_cond_expr;
3187 else
3188 gnu_result = gnu_loop_stmt;
3190 gnu_loop_stack->pop ();
3192 return gnu_result;
3195 /* This page implements a form of Named Return Value optimization modelled
3196 on the C++ optimization of the same name. The main difference is that
3197 we disregard any semantical considerations when applying it here, the
3198 counterpart being that we don't try to apply it to semantically loaded
3199 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3201 We consider a function body of the following GENERIC form:
3203 return_type R1;
3204 [...]
3205 RETURN_EXPR [<retval> = ...]
3206 [...]
3207 RETURN_EXPR [<retval> = R1]
3208 [...]
3209 return_type Ri;
3210 [...]
3211 RETURN_EXPR [<retval> = ...]
3212 [...]
3213 RETURN_EXPR [<retval> = Ri]
3214 [...]
3216 and we try to fulfill a simple criterion that would make it possible to
3217 replace one or several Ri variables with the RESULT_DECL of the function.
3219 The first observation is that RETURN_EXPRs that don't directly reference
3220 any of the Ri variables on the RHS of their assignment are transparent wrt
3221 the optimization. This is because the Ri variables aren't addressable so
3222 any transformation applied to them doesn't affect the RHS; moreover, the
3223 assignment writes the full <retval> object so existing values are entirely
3224 discarded.
3226 This property can be extended to some forms of RETURN_EXPRs that reference
3227 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3228 case, in particular when function calls are involved.
3230 Therefore the algorithm is as follows:
3232 1. Collect the list of candidates for a Named Return Value (Ri variables
3233 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3234 other expressions on the RHS of such assignments.
3236 2. Prune the members of the first list (candidates) that are referenced
3237 by a member of the second list (expressions).
3239 3. Extract a set of candidates with non-overlapping live ranges from the
3240 first list. These are the Named Return Values.
3242 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3243 Named Return Values in the function with the RESULT_DECL.
3245 If the function returns an unconstrained type, things are a bit different
3246 because the anonymous return object is allocated on the secondary stack
3247 and RESULT_DECL is only a pointer to it. Each return object can be of a
3248 different size and is allocated separately so we need not care about the
3249 aforementioned overlapping issues. Therefore, we don't collect the other
3250 expressions and skip step #2 in the algorithm. */
3252 struct nrv_data
3254 bitmap nrv;
3255 tree result;
3256 Node_Id gnat_ret;
3257 hash_set<tree> *visited;
3260 /* Return true if T is a Named Return Value. */
3262 static inline bool
3263 is_nrv_p (bitmap nrv, tree t)
3265 return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
3268 /* Helper function for walk_tree, used by finalize_nrv below. */
3270 static tree
3271 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
3273 struct nrv_data *dp = (struct nrv_data *)data;
3274 tree t = *tp;
3276 /* No need to walk into types or decls. */
3277 if (IS_TYPE_OR_DECL_P (t))
3278 *walk_subtrees = 0;
3280 if (is_nrv_p (dp->nrv, t))
3281 bitmap_clear_bit (dp->nrv, DECL_UID (t));
3283 return NULL_TREE;
3286 /* Prune Named Return Values in BLOCK and return true if there is still a
3287 Named Return Value in BLOCK or one of its sub-blocks. */
3289 static bool
3290 prune_nrv_in_block (bitmap nrv, tree block)
3292 bool has_nrv = false;
3293 tree t;
3295 /* First recurse on the sub-blocks. */
3296 for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
3297 has_nrv |= prune_nrv_in_block (nrv, t);
3299 /* Then make sure to keep at most one NRV per block. */
3300 for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
3301 if (is_nrv_p (nrv, t))
3303 if (has_nrv)
3304 bitmap_clear_bit (nrv, DECL_UID (t));
3305 else
3306 has_nrv = true;
3309 return has_nrv;
3312 /* Helper function for walk_tree, used by finalize_nrv below. */
3314 static tree
3315 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
3317 struct nrv_data *dp = (struct nrv_data *)data;
3318 tree t = *tp;
3320 /* No need to walk into types. */
3321 if (TYPE_P (t))
3322 *walk_subtrees = 0;
3324 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3325 nop, but differs from using NULL_TREE in that it indicates that we care
3326 about the value of the RESULT_DECL. */
3327 else if (TREE_CODE (t) == RETURN_EXPR
3328 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3330 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1), init_expr;
3332 /* If this is the temporary created for a return value with variable
3333 size in Call_to_gnu, we replace the RHS with the init expression. */
3334 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3335 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3336 && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3337 == TREE_OPERAND (ret_val, 1))
3339 init_expr = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3340 ret_val = TREE_OPERAND (ret_val, 1);
3342 else
3343 init_expr = NULL_TREE;
3345 /* Strip useless conversions around the return value. */
3346 if (gnat_useless_type_conversion (ret_val))
3347 ret_val = TREE_OPERAND (ret_val, 0);
3349 if (is_nrv_p (dp->nrv, ret_val))
3351 if (init_expr)
3352 TREE_OPERAND (TREE_OPERAND (t, 0), 1) = init_expr;
3353 else
3354 TREE_OPERAND (t, 0) = dp->result;
3358 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3359 if needed. */
3360 else if (TREE_CODE (t) == DECL_EXPR
3361 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3363 tree var = DECL_EXPR_DECL (t), init;
3365 if (DECL_INITIAL (var))
3367 init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
3368 DECL_INITIAL (var));
3369 SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
3370 DECL_INITIAL (var) = NULL_TREE;
3372 else
3373 init = build_empty_stmt (EXPR_LOCATION (t));
3374 *tp = init;
3376 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3377 SET_DECL_VALUE_EXPR (var, dp->result);
3378 DECL_HAS_VALUE_EXPR_P (var) = 1;
3379 /* ??? Kludge to avoid an assertion failure during inlining. */
3380 DECL_SIZE (var) = bitsize_unit_node;
3381 DECL_SIZE_UNIT (var) = size_one_node;
3384 /* And replace all uses of NRVs with the RESULT_DECL. */
3385 else if (is_nrv_p (dp->nrv, t))
3386 *tp = convert (TREE_TYPE (t), dp->result);
3388 /* Avoid walking into the same tree more than once. Unfortunately, we
3389 can't just use walk_tree_without_duplicates because it would only
3390 call us for the first occurrence of NRVs in the function body. */
3391 if (dp->visited->add (*tp))
3392 *walk_subtrees = 0;
3394 return NULL_TREE;
3397 /* Likewise, but used when the function returns an unconstrained type. */
3399 static tree
3400 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
3402 struct nrv_data *dp = (struct nrv_data *)data;
3403 tree t = *tp;
3405 /* No need to walk into types. */
3406 if (TYPE_P (t))
3407 *walk_subtrees = 0;
3409 /* We need to see the DECL_EXPR of NRVs before any other references so we
3410 walk the body of BIND_EXPR before walking its variables. */
3411 else if (TREE_CODE (t) == BIND_EXPR)
3412 walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
3414 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3415 return value built by the allocator instead of the whole construct. */
3416 else if (TREE_CODE (t) == RETURN_EXPR
3417 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3419 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3421 /* This is the construct returned by the allocator. */
3422 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3423 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
3425 tree rhs = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3427 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
3428 ret_val = CONSTRUCTOR_ELT (rhs, 1)->value;
3429 else
3430 ret_val = rhs;
3433 /* Strip useless conversions around the return value. */
3434 if (gnat_useless_type_conversion (ret_val)
3435 || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
3436 ret_val = TREE_OPERAND (ret_val, 0);
3438 /* Strip unpadding around the return value. */
3439 if (TREE_CODE (ret_val) == COMPONENT_REF
3440 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
3441 ret_val = TREE_OPERAND (ret_val, 0);
3443 /* Assign the new return value to the RESULT_DECL. */
3444 if (is_nrv_p (dp->nrv, ret_val))
3445 TREE_OPERAND (TREE_OPERAND (t, 0), 1)
3446 = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
3449 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3450 into a new variable. */
3451 else if (TREE_CODE (t) == DECL_EXPR
3452 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3454 tree saved_current_function_decl = current_function_decl;
3455 tree var = DECL_EXPR_DECL (t);
3456 tree alloc, p_array, new_var, new_ret;
3457 vec<constructor_elt, va_gc> *v;
3458 vec_alloc (v, 2);
3460 /* Create an artificial context to build the allocation. */
3461 current_function_decl = decl_function_context (var);
3462 start_stmt_group ();
3463 gnat_pushlevel ();
3465 /* This will return a COMPOUND_EXPR with the allocation in the first
3466 arm and the final return value in the second arm. */
3467 alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
3468 TREE_TYPE (dp->result),
3469 Procedure_To_Call (dp->gnat_ret),
3470 Storage_Pool (dp->gnat_ret),
3471 Empty, false);
3473 /* The new variable is built as a reference to the allocated space. */
3474 new_var
3475 = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
3476 build_reference_type (TREE_TYPE (var)));
3477 DECL_BY_REFERENCE (new_var) = 1;
3479 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
3481 tree cst = TREE_OPERAND (alloc, 1);
3483 /* The new initial value is a COMPOUND_EXPR with the allocation in
3484 the first arm and the value of P_ARRAY in the second arm. */
3485 DECL_INITIAL (new_var)
3486 = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
3487 TREE_OPERAND (alloc, 0),
3488 CONSTRUCTOR_ELT (cst, 0)->value);
3490 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3491 p_array = TYPE_FIELDS (TREE_TYPE (alloc));
3492 CONSTRUCTOR_APPEND_ELT (v, p_array,
3493 fold_convert (TREE_TYPE (p_array), new_var));
3494 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
3495 CONSTRUCTOR_ELT (cst, 1)->value);
3496 new_ret = build_constructor (TREE_TYPE (alloc), v);
3498 else
3500 /* The new initial value is just the allocation. */
3501 DECL_INITIAL (new_var) = alloc;
3502 new_ret = fold_convert (TREE_TYPE (alloc), new_var);
3505 gnat_pushdecl (new_var, Empty);
3507 /* Destroy the artificial context and insert the new statements. */
3508 gnat_zaplevel ();
3509 *tp = end_stmt_group ();
3510 current_function_decl = saved_current_function_decl;
3512 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3513 DECL_CHAIN (new_var) = DECL_CHAIN (var);
3514 DECL_CHAIN (var) = new_var;
3515 DECL_IGNORED_P (var) = 1;
3517 /* Save the new return value and the dereference of NEW_VAR. */
3518 DECL_INITIAL (var)
3519 = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
3520 build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
3521 /* ??? Kludge to avoid messing up during inlining. */
3522 DECL_CONTEXT (var) = NULL_TREE;
3525 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3526 else if (is_nrv_p (dp->nrv, t))
3527 *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3529 /* Avoid walking into the same tree more than once. Unfortunately, we
3530 can't just use walk_tree_without_duplicates because it would only
3531 call us for the first occurrence of NRVs in the function body. */
3532 if (dp->visited->add (*tp))
3533 *walk_subtrees = 0;
3535 return NULL_TREE;
3538 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3539 contains the candidates for Named Return Value and OTHER is a list of
3540 the other return values. GNAT_RET is a representative return node. */
3542 static void
3543 finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret)
3545 struct cgraph_node *node;
3546 struct nrv_data data;
3547 walk_tree_fn func;
3548 unsigned int i;
3549 tree iter;
3551 /* We shouldn't be applying the optimization to return types that we aren't
3552 allowed to manipulate freely. */
3553 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3555 /* Prune the candidates that are referenced by other return values. */
3556 data.nrv = nrv;
3557 data.result = NULL_TREE;
3558 data.gnat_ret = Empty;
3559 data.visited = NULL;
3560 FOR_EACH_VEC_SAFE_ELT (other, i, iter)
3561 walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3562 if (bitmap_empty_p (nrv))
3563 return;
3565 /* Prune also the candidates that are referenced by nested functions. */
3566 node = cgraph_node::get_create (fndecl);
3567 for (node = node->nested; node; node = node->next_nested)
3568 walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r,
3569 &data);
3570 if (bitmap_empty_p (nrv))
3571 return;
3573 /* Extract a set of NRVs with non-overlapping live ranges. */
3574 if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3575 return;
3577 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3578 data.nrv = nrv;
3579 data.result = DECL_RESULT (fndecl);
3580 data.gnat_ret = gnat_ret;
3581 data.visited = new hash_set<tree>;
3582 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3583 func = finalize_nrv_unc_r;
3584 else
3585 func = finalize_nrv_r;
3586 walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3587 delete data.visited;
3590 /* Return true if RET_VAL can be used as a Named Return Value for the
3591 anonymous return object RET_OBJ. */
3593 static bool
3594 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3596 if (TREE_CODE (ret_val) != VAR_DECL)
3597 return false;
3599 if (TREE_THIS_VOLATILE (ret_val))
3600 return false;
3602 if (DECL_CONTEXT (ret_val) != current_function_decl)
3603 return false;
3605 if (TREE_STATIC (ret_val))
3606 return false;
3608 if (TREE_ADDRESSABLE (ret_val))
3609 return false;
3611 if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3612 return false;
3614 return true;
3617 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3618 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3619 around RESULT_OBJ, which may be null in this case. */
3621 static tree
3622 build_return_expr (tree ret_obj, tree ret_val)
3624 tree result_expr;
3626 if (ret_val)
3628 /* The gimplifier explicitly enforces the following invariant:
3630 RETURN_EXPR
3632 INIT_EXPR
3635 RET_OBJ ...
3637 As a consequence, type consistency dictates that we use the type
3638 of the RET_OBJ as the operation type. */
3639 tree operation_type = TREE_TYPE (ret_obj);
3641 /* Convert the right operand to the operation type. Note that this is
3642 the transformation applied in the INIT_EXPR case of build_binary_op,
3643 with the assumption that the type cannot involve a placeholder. */
3644 if (operation_type != TREE_TYPE (ret_val))
3645 ret_val = convert (operation_type, ret_val);
3647 /* We always can use an INIT_EXPR for the return object. */
3648 result_expr = build2 (INIT_EXPR, void_type_node, ret_obj, ret_val);
3650 /* If the function returns an aggregate type, find out whether this is
3651 a candidate for Named Return Value. If so, record it. Otherwise,
3652 if this is an expression of some kind, record it elsewhere. */
3653 if (optimize
3654 && AGGREGATE_TYPE_P (operation_type)
3655 && !TYPE_IS_FAT_POINTER_P (operation_type)
3656 && TYPE_MODE (operation_type) == BLKmode
3657 && aggregate_value_p (operation_type, current_function_decl))
3659 /* Recognize the temporary created for a return value with variable
3660 size in Call_to_gnu. We want to eliminate it if possible. */
3661 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3662 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3663 && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3664 == TREE_OPERAND (ret_val, 1))
3665 ret_val = TREE_OPERAND (ret_val, 1);
3667 /* Strip useless conversions around the return value. */
3668 if (gnat_useless_type_conversion (ret_val))
3669 ret_val = TREE_OPERAND (ret_val, 0);
3671 /* Now apply the test to the return value. */
3672 if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3674 if (!f_named_ret_val)
3675 f_named_ret_val = BITMAP_GGC_ALLOC ();
3676 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3679 /* Note that we need not care about CONSTRUCTORs here, as they are
3680 totally transparent given the read-compose-write semantics of
3681 assignments from CONSTRUCTORs. */
3682 else if (EXPR_P (ret_val))
3683 vec_safe_push (f_other_ret_val, ret_val);
3686 else
3687 result_expr = ret_obj;
3689 return build1 (RETURN_EXPR, void_type_node, result_expr);
3692 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3693 don't return anything. */
3695 static void
3696 Subprogram_Body_to_gnu (Node_Id gnat_node)
3698 /* Defining identifier of a parameter to the subprogram. */
3699 Entity_Id gnat_param;
3700 /* The defining identifier for the subprogram body. Note that if a
3701 specification has appeared before for this body, then the identifier
3702 occurring in that specification will also be a defining identifier and all
3703 the calls to this subprogram will point to that specification. */
3704 Entity_Id gnat_subprog_id
3705 = (Present (Corresponding_Spec (gnat_node))
3706 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3707 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3708 tree gnu_subprog_decl;
3709 /* Its RESULT_DECL node. */
3710 tree gnu_result_decl;
3711 /* Its FUNCTION_TYPE node. */
3712 tree gnu_subprog_type;
3713 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3714 tree gnu_cico_list;
3715 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3716 tree gnu_return_var_elmt = NULL_TREE;
3717 tree gnu_result;
3718 location_t locus;
3719 struct language_function *gnu_subprog_language;
3720 vec<parm_attr, va_gc> *cache;
3722 /* If this is a generic object or if it has been eliminated,
3723 ignore it. */
3724 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
3725 || Ekind (gnat_subprog_id) == E_Generic_Function
3726 || Is_Eliminated (gnat_subprog_id))
3727 return;
3729 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3730 the already-elaborated tree node. However, if this subprogram had its
3731 elaboration deferred, we will already have made a tree node for it. So
3732 treat it as not being defined in that case. Such a subprogram cannot
3733 have an address clause or a freeze node, so this test is safe, though it
3734 does disable some otherwise-useful error checking. */
3735 gnu_subprog_decl
3736 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
3737 Acts_As_Spec (gnat_node)
3738 && !present_gnu_tree (gnat_subprog_id));
3739 gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
3740 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
3741 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3742 if (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node)
3743 gnu_return_var_elmt = gnu_cico_list;
3745 /* If the function returns by invisible reference, make it explicit in the
3746 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
3747 if (TREE_ADDRESSABLE (gnu_subprog_type))
3749 TREE_TYPE (gnu_result_decl)
3750 = build_reference_type (TREE_TYPE (gnu_result_decl));
3751 relayout_decl (gnu_result_decl);
3754 /* Set the line number in the decl to correspond to that of the body. */
3755 Sloc_to_locus (Sloc (gnat_node), &locus);
3756 DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus;
3758 /* Initialize the information structure for the function. */
3759 allocate_struct_function (gnu_subprog_decl, false);
3760 gnu_subprog_language = ggc_cleared_alloc<language_function> ();
3761 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
3762 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_start_locus = locus;
3763 set_cfun (NULL);
3765 begin_subprog_body (gnu_subprog_decl);
3767 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3768 properly copied out by the return statement. We do this by making a new
3769 block and converting any return into a goto to a label at the end of the
3770 block. */
3771 if (gnu_cico_list)
3773 tree gnu_return_var = NULL_TREE;
3775 vec_safe_push (gnu_return_label_stack,
3776 create_artificial_label (input_location));
3778 start_stmt_group ();
3779 gnat_pushlevel ();
3781 /* If this is a function with copy-in/copy-out parameters and which does
3782 not return by invisible reference, we also need a variable for the
3783 return value to be placed. */
3784 if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type))
3786 tree gnu_return_type
3787 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3789 gnu_return_var
3790 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3791 gnu_return_type, NULL_TREE, false, false,
3792 false, false, true, false,
3793 NULL, gnat_subprog_id);
3794 TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3797 vec_safe_push (gnu_return_var_stack, gnu_return_var);
3799 /* See whether there are parameters for which we don't have a GCC tree
3800 yet. These must be Out parameters. Make a VAR_DECL for them and
3801 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3802 We can match up the entries because TYPE_CI_CO_LIST is in the order
3803 of the parameters. */
3804 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3805 Present (gnat_param);
3806 gnat_param = Next_Formal_With_Extras (gnat_param))
3807 if (!present_gnu_tree (gnat_param))
3809 tree gnu_cico_entry = gnu_cico_list;
3810 tree gnu_decl;
3812 /* Skip any entries that have been already filled in; they must
3813 correspond to In Out parameters. */
3814 while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3815 gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3817 /* Do any needed dereferences for by-ref objects. */
3818 gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, 1);
3819 gcc_assert (DECL_P (gnu_decl));
3820 if (DECL_BY_REF_P (gnu_decl))
3821 gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
3823 /* Do any needed references for padded types. */
3824 TREE_VALUE (gnu_cico_entry)
3825 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl);
3828 else
3829 vec_safe_push (gnu_return_label_stack, NULL_TREE);
3831 /* Get a tree corresponding to the code for the subprogram. */
3832 start_stmt_group ();
3833 gnat_pushlevel ();
3835 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3837 /* Generate the code of the subprogram itself. A return statement will be
3838 present and any Out parameters will be handled there. */
3839 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3840 gnat_poplevel ();
3841 gnu_result = end_stmt_group ();
3843 /* If we populated the parameter attributes cache, we need to make sure that
3844 the cached expressions are evaluated on all the possible paths leading to
3845 their uses. So we force their evaluation on entry of the function. */
3846 cache = gnu_subprog_language->parm_attr_cache;
3847 if (cache)
3849 struct parm_attr_d *pa;
3850 int i;
3852 start_stmt_group ();
3854 FOR_EACH_VEC_ELT (*cache, i, pa)
3856 if (pa->first)
3857 add_stmt_with_node_force (pa->first, gnat_node);
3858 if (pa->last)
3859 add_stmt_with_node_force (pa->last, gnat_node);
3860 if (pa->length)
3861 add_stmt_with_node_force (pa->length, gnat_node);
3864 add_stmt (gnu_result);
3865 gnu_result = end_stmt_group ();
3867 gnu_subprog_language->parm_attr_cache = NULL;
3870 /* If we are dealing with a return from an Ada procedure with parameters
3871 passed by copy-in/copy-out, we need to return a record containing the
3872 final values of these parameters. If the list contains only one entry,
3873 return just that entry though.
3875 For a full description of the copy-in/copy-out parameter mechanism, see
3876 the part of the gnat_to_gnu_entity routine dealing with the translation
3877 of subprograms.
3879 We need to make a block that contains the definition of that label and
3880 the copying of the return value. It first contains the function, then
3881 the label and copy statement. */
3882 if (gnu_cico_list)
3884 const Node_Id gnat_end_label
3885 = End_Label (Handled_Statement_Sequence (gnat_node));
3887 gnu_return_var_stack->pop ();
3889 add_stmt (gnu_result);
3890 add_stmt (build1 (LABEL_EXPR, void_type_node,
3891 gnu_return_label_stack->last ()));
3893 /* If this is a function which returns by invisible reference, the
3894 return value has already been dealt with at the return statements,
3895 so we only need to indirectly copy out the parameters. */
3896 if (TREE_ADDRESSABLE (gnu_subprog_type))
3898 tree gnu_ret_deref
3899 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl);
3900 tree t;
3902 gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node);
3904 for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t))
3906 tree gnu_field_deref
3907 = build_component_ref (gnu_ret_deref, TREE_PURPOSE (t), true);
3908 gnu_result = build2 (MODIFY_EXPR, void_type_node,
3909 gnu_field_deref, TREE_VALUE (t));
3910 add_stmt_with_node (gnu_result, gnat_end_label);
3914 /* Otherwise, if this is a procedure or a function which does not return
3915 by invisible reference, we can do a direct block-copy out. */
3916 else
3918 tree gnu_retval;
3920 if (list_length (gnu_cico_list) == 1)
3921 gnu_retval = TREE_VALUE (gnu_cico_list);
3922 else
3923 gnu_retval
3924 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
3925 gnu_cico_list);
3927 gnu_result = build_return_expr (gnu_result_decl, gnu_retval);
3928 add_stmt_with_node (gnu_result, gnat_end_label);
3931 gnat_poplevel ();
3932 gnu_result = end_stmt_group ();
3935 gnu_return_label_stack->pop ();
3937 /* Attempt setting the end_locus of our GCC body tree, typically a
3938 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
3939 declaration tree. */
3940 set_end_locus_from_node (gnu_result, gnat_node);
3941 set_end_locus_from_node (gnu_subprog_decl, gnat_node);
3943 /* On SEH targets, install an exception handler around the main entry
3944 point to catch unhandled exceptions. */
3945 if (DECL_NAME (gnu_subprog_decl) == main_identifier_node
3946 && targetm_common.except_unwind_info (&global_options) == UI_SEH)
3948 tree t;
3949 tree etype;
3951 t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
3952 1, integer_zero_node);
3953 t = build_call_n_expr (unhandled_except_decl, 1, t);
3955 etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl);
3956 etype = tree_cons (NULL_TREE, etype, NULL_TREE);
3958 t = build2 (CATCH_EXPR, void_type_node, etype, t);
3959 gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result),
3960 gnu_result, t);
3963 end_subprog_body (gnu_result);
3965 /* Finally annotate the parameters and disconnect the trees for parameters
3966 that we have turned into variables since they are now unusable. */
3967 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3968 Present (gnat_param);
3969 gnat_param = Next_Formal_With_Extras (gnat_param))
3971 tree gnu_param = get_gnu_tree (gnat_param);
3972 bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
3974 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
3975 DECL_BY_REF_P (gnu_param));
3977 if (is_var_decl)
3978 save_gnu_tree (gnat_param, NULL_TREE, false);
3981 /* Disconnect the variable created for the return value. */
3982 if (gnu_return_var_elmt)
3983 TREE_VALUE (gnu_return_var_elmt) = void_type_node;
3985 /* If the function returns an aggregate type and we have candidates for
3986 a Named Return Value, finalize the optimization. */
3987 if (optimize && gnu_subprog_language->named_ret_val)
3989 finalize_nrv (gnu_subprog_decl,
3990 gnu_subprog_language->named_ret_val,
3991 gnu_subprog_language->other_ret_val,
3992 gnu_subprog_language->gnat_ret);
3993 gnu_subprog_language->named_ret_val = NULL;
3994 gnu_subprog_language->other_ret_val = NULL;
3997 /* If this is an inlined external function that has been marked uninlinable,
3998 drop the body and stop there. Otherwise compile the body. */
3999 if (DECL_EXTERNAL (gnu_subprog_decl) && DECL_UNINLINABLE (gnu_subprog_decl))
4000 DECL_SAVED_TREE (gnu_subprog_decl) = NULL_TREE;
4001 else
4002 rest_of_subprog_body_compilation (gnu_subprog_decl);
4005 /* Return true if GNAT_NODE references an Atomic entity. */
4007 static bool
4008 node_is_atomic (Node_Id gnat_node)
4010 Entity_Id gnat_entity;
4012 switch (Nkind (gnat_node))
4014 case N_Identifier:
4015 case N_Expanded_Name:
4016 gnat_entity = Entity (gnat_node);
4017 if (Ekind (gnat_entity) != E_Variable)
4018 break;
4019 return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
4021 case N_Selected_Component:
4022 gnat_entity = Entity (Selector_Name (gnat_node));
4023 return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
4025 case N_Indexed_Component:
4026 if (Has_Atomic_Components (Etype (Prefix (gnat_node))))
4027 return true;
4029 /* ... fall through ... */
4031 case N_Explicit_Dereference:
4032 return Is_Atomic (Etype (gnat_node));
4034 default:
4035 break;
4038 return false;
4041 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. */
4043 static bool
4044 node_has_volatile_full_access (Node_Id gnat_node)
4046 Entity_Id gnat_entity;
4048 switch (Nkind (gnat_node))
4050 case N_Identifier:
4051 case N_Expanded_Name:
4052 gnat_entity = Entity (gnat_node);
4053 if (Ekind (gnat_entity) != E_Variable)
4054 break;
4055 return Is_Volatile_Full_Access (gnat_entity)
4056 || Is_Volatile_Full_Access (Etype (gnat_entity));
4058 case N_Selected_Component:
4059 gnat_entity = Entity (Selector_Name (gnat_node));
4060 return Is_Volatile_Full_Access (gnat_entity)
4061 || Is_Volatile_Full_Access (Etype (gnat_entity));
4063 case N_Indexed_Component:
4064 case N_Explicit_Dereference:
4065 return Is_Volatile_Full_Access (Etype (gnat_node));
4067 default:
4068 break;
4071 return false;
4074 /* Strip any type conversion on GNAT_NODE and return the result. */
4076 static Node_Id
4077 gnat_strip_type_conversion (Node_Id gnat_node)
4079 Node_Kind kind = Nkind (gnat_node);
4081 if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
4082 gnat_node = Expression (gnat_node);
4084 return gnat_node;
4087 /* Return true if GNAT_NODE requires outer atomic access, i.e. atomic access
4088 of an object of which GNAT_NODE is a component. */
4090 static bool
4091 outer_atomic_access_required_p (Node_Id gnat_node)
4093 gnat_node = gnat_strip_type_conversion (gnat_node);
4095 while (true)
4097 switch (Nkind (gnat_node))
4099 case N_Identifier:
4100 case N_Expanded_Name:
4101 if (No (Renamed_Object (Entity (gnat_node))))
4102 return false;
4103 gnat_node
4104 = gnat_strip_type_conversion (Renamed_Object (Entity (gnat_node)));
4105 break;
4107 case N_Indexed_Component:
4108 case N_Selected_Component:
4109 case N_Slice:
4110 gnat_node = gnat_strip_type_conversion (Prefix (gnat_node));
4111 if (node_has_volatile_full_access (gnat_node))
4112 return true;
4113 break;
4115 default:
4116 return false;
4120 gcc_unreachable ();
4123 /* Return true if GNAT_NODE requires atomic access and set SYNC according to
4124 the associated synchronization setting. */
4126 static bool
4127 atomic_access_required_p (Node_Id gnat_node, bool *sync)
4129 const Node_Id gnat_parent = Parent (gnat_node);
4130 unsigned char attr_id;
4131 bool as_a_whole = true;
4133 /* First, scan the parent to find out cases where the flag is irrelevant. */
4134 switch (Nkind (gnat_parent))
4136 case N_Attribute_Reference:
4137 attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
4138 /* Do not mess up machine code insertions. */
4139 if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
4140 return false;
4142 /* Nothing to do if we are the prefix of an attribute, since we do not
4143 want an atomic access for things like 'Size. */
4145 /* ... fall through ... */
4147 case N_Reference:
4148 /* The N_Reference node is like an attribute. */
4149 if (Prefix (gnat_parent) == gnat_node)
4150 return false;
4151 break;
4153 case N_Indexed_Component:
4154 case N_Selected_Component:
4155 case N_Slice:
4156 /* If we are the prefix, then the access is only partial. */
4157 if (Prefix (gnat_parent) == gnat_node)
4158 as_a_whole = false;
4159 break;
4161 case N_Object_Renaming_Declaration:
4162 /* Nothing to do for the identifier in an object renaming declaration,
4163 the renaming itself does not need atomic access. */
4164 return false;
4166 default:
4167 break;
4170 /* Then, scan the node to find the atomic object. */
4171 gnat_node = gnat_strip_type_conversion (gnat_node);
4173 /* For Atomic itself, only reads and updates of the object as a whole require
4174 atomic access (RM C.6 (15)). But for Volatile_Full_Access, all reads and
4175 updates require atomic access. */
4176 if (!(as_a_whole && node_is_atomic (gnat_node))
4177 && !node_has_volatile_full_access (gnat_node))
4178 return false;
4180 /* If an outer atomic access will also be required, it cancels this one. */
4181 if (outer_atomic_access_required_p (gnat_node))
4182 return false;
4184 *sync = Atomic_Sync_Required (gnat_node);
4186 return true;
4189 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4191 static tree
4192 create_temporary (const char *prefix, tree type)
4194 tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
4195 type, NULL_TREE, false, false, false, false,
4196 true, false, NULL, Empty);
4197 return gnu_temp;
4200 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4201 Put the initialization statement into GNU_INIT_STMT and annotate it with
4202 the SLOC of GNAT_NODE. Return the temporary variable. */
4204 static tree
4205 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
4206 Node_Id gnat_node)
4208 tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
4210 *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
4211 set_expr_location_from_node (*gnu_init_stmt, gnat_node);
4213 return gnu_temp;
4216 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4217 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4218 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4219 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4220 N_Assignment_Statement and the result is to be placed into that object.
4221 If OUTER_ATOMIC_ACCESS is true, then the assignment to GNU_TARGET must be a
4222 load-modify-store sequence. Otherwise, if ATOMIC_ACCESS is true, then the
4223 assignment to GNU_TARGET must be atomic. If, in addition, ATOMIC_SYNC is
4224 true, then the assignment to GNU_TARGET requires atomic synchronization. */
4226 static tree
4227 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
4228 bool outer_atomic_access, bool atomic_access, bool atomic_sync)
4230 const bool function_call = (Nkind (gnat_node) == N_Function_Call);
4231 const bool returning_value = (function_call && !gnu_target);
4232 /* The GCC node corresponding to the GNAT subprogram name. This can either
4233 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4234 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4235 subprogram. */
4236 tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
4237 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4238 tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
4239 /* The return type of the FUNCTION_TYPE. */
4240 tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
4241 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
4242 vec<tree, va_gc> *gnu_actual_vec = NULL;
4243 tree gnu_name_list = NULL_TREE;
4244 tree gnu_stmt_list = NULL_TREE;
4245 tree gnu_after_list = NULL_TREE;
4246 tree gnu_retval = NULL_TREE;
4247 tree gnu_call, gnu_result;
4248 bool went_into_elab_proc = false;
4249 bool pushed_binding_level = false;
4250 Entity_Id gnat_formal;
4251 Node_Id gnat_actual;
4252 bool sync;
4254 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
4256 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
4257 all our args first. */
4258 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
4260 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
4261 gnat_node, N_Raise_Program_Error);
4263 for (gnat_actual = First_Actual (gnat_node);
4264 Present (gnat_actual);
4265 gnat_actual = Next_Actual (gnat_actual))
4266 add_stmt (gnat_to_gnu (gnat_actual));
4268 if (returning_value)
4270 *gnu_result_type_p = gnu_result_type;
4271 return build1 (NULL_EXPR, gnu_result_type, call_expr);
4274 return call_expr;
4277 /* For a call to a nested function, check the inlining status. */
4278 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL
4279 && decl_function_context (gnu_subprog))
4280 check_inlining_for_nested_subprog (gnu_subprog);
4282 /* The only way we can be making a call via an access type is if Name is an
4283 explicit dereference. In that case, get the list of formal args from the
4284 type the access type is pointing to. Otherwise, get the formals from the
4285 entity being called. */
4286 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4287 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4288 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
4289 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4290 gnat_formal = Empty;
4291 else
4292 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4294 /* The lifetime of the temporaries created for the call ends right after the
4295 return value is copied, so we can give them the scope of the elaboration
4296 routine at top level. */
4297 if (!current_function_decl)
4299 current_function_decl = get_elaboration_procedure ();
4300 went_into_elab_proc = true;
4303 /* First, create the temporary for the return value when:
4305 1. There is no target and the function has copy-in/copy-out parameters,
4306 because we need to preserve the return value before copying back the
4307 parameters.
4309 2. There is no target and this is neither an object nor a renaming
4310 declaration, and the return type has variable size, because in
4311 these cases the gimplifier cannot create the temporary.
4313 3. There is a target and it is a slice or an array with fixed size,
4314 and the return type has variable size, because the gimplifier
4315 doesn't handle these cases.
4317 This must be done before we push a binding level around the call, since
4318 we will pop it before copying the return value. */
4319 if (function_call
4320 && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
4321 || (!gnu_target
4322 && Nkind (Parent (gnat_node)) != N_Object_Declaration
4323 && Nkind (Parent (gnat_node)) != N_Object_Renaming_Declaration
4324 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
4325 || (gnu_target
4326 && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
4327 || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
4328 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
4329 == INTEGER_CST))
4330 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
4331 gnu_retval = create_temporary ("R", gnu_result_type);
4333 /* Create the list of the actual parameters as GCC expects it, namely a
4334 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4335 is an expression and the TREE_PURPOSE field is null. But skip Out
4336 parameters not passed by reference and that need not be copied in. */
4337 for (gnat_actual = First_Actual (gnat_node);
4338 Present (gnat_actual);
4339 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4340 gnat_actual = Next_Actual (gnat_actual))
4342 Entity_Id gnat_formal_type = Etype (gnat_formal);
4343 tree gnu_formal = present_gnu_tree (gnat_formal)
4344 ? get_gnu_tree (gnat_formal) : NULL_TREE;
4345 tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
4346 const bool is_true_formal_parm
4347 = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
4348 const bool is_by_ref_formal_parm
4349 = is_true_formal_parm
4350 && (DECL_BY_REF_P (gnu_formal)
4351 || DECL_BY_COMPONENT_PTR_P (gnu_formal));
4352 /* In the Out or In Out case, we must suppress conversions that yield
4353 an lvalue but can nevertheless cause the creation of a temporary,
4354 because we need the real object in this case, either to pass its
4355 address if it's passed by reference or as target of the back copy
4356 done after the call if it uses the copy-in/copy-out mechanism.
4357 We do it in the In case too, except for an unchecked conversion
4358 to an elementary type or a constrained composite type because it
4359 alone can cause the actual to be misaligned and the addressability
4360 test is applied to the real object. */
4361 const bool suppress_type_conversion
4362 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
4363 && (Ekind (gnat_formal) != E_In_Parameter
4364 || (Is_Composite_Type (Underlying_Type (gnat_formal_type))
4365 && !Is_Constrained (Underlying_Type (gnat_formal_type)))))
4366 || (Nkind (gnat_actual) == N_Type_Conversion
4367 && Is_Composite_Type (Underlying_Type (gnat_formal_type))));
4368 Node_Id gnat_name = suppress_type_conversion
4369 ? Expression (gnat_actual) : gnat_actual;
4370 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
4371 tree gnu_actual;
4373 /* If it's possible we may need to use this expression twice, make sure
4374 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4375 to force side-effects before the call. */
4376 if (Ekind (gnat_formal) != E_In_Parameter
4377 && !is_by_ref_formal_parm
4378 && TREE_CODE (gnu_name) != NULL_EXPR)
4380 tree init = NULL_TREE;
4381 gnu_name = gnat_stabilize_reference (gnu_name, true, &init);
4382 if (init)
4383 gnu_name
4384 = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
4387 /* If we are passing a non-addressable parameter by reference, pass the
4388 address of a copy. In the Out or In Out case, set up to copy back
4389 out after the call. */
4390 if (is_by_ref_formal_parm
4391 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
4392 && !addressable_p (gnu_name, gnu_name_type))
4394 bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
4395 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
4397 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4398 but sort of an instantiation for them. */
4399 if (TREE_CODE (gnu_name) == CONSTRUCTOR)
4402 /* If the type is passed by reference, a copy is not allowed. */
4403 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type))
4404 post_error ("misaligned actual cannot be passed by reference",
4405 gnat_actual);
4407 /* For users of Starlet we issue a warning because the interface
4408 apparently assumes that by-ref parameters outlive the procedure
4409 invocation. The code still will not work as intended, but we
4410 cannot do much better since low-level parts of the back-end
4411 would allocate temporaries at will because of the misalignment
4412 if we did not do so here. */
4413 else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
4415 post_error
4416 ("?possible violation of implicit assumption", gnat_actual);
4417 post_error_ne
4418 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
4419 Entity (Name (gnat_node)));
4420 post_error_ne ("?because of misalignment of &", gnat_actual,
4421 gnat_formal);
4424 /* If the actual type of the object is already the nominal type,
4425 we have nothing to do, except if the size is self-referential
4426 in which case we'll remove the unpadding below. */
4427 if (TREE_TYPE (gnu_name) == gnu_name_type
4428 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
4431 /* Otherwise remove the unpadding from all the objects. */
4432 else if (TREE_CODE (gnu_name) == COMPONENT_REF
4433 && TYPE_IS_PADDING_P
4434 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
4435 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
4437 /* Otherwise convert to the nominal type of the object if needed.
4438 There are several cases in which we need to make the temporary
4439 using this type instead of the actual type of the object when
4440 they are distinct, because the expectations of the callee would
4441 otherwise not be met:
4442 - if it's a justified modular type,
4443 - if the actual type is a smaller form of it,
4444 - if it's a smaller form of the actual type. */
4445 else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
4446 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
4447 || smaller_form_type_p (TREE_TYPE (gnu_name),
4448 gnu_name_type)))
4449 || (INTEGRAL_TYPE_P (gnu_name_type)
4450 && smaller_form_type_p (gnu_name_type,
4451 TREE_TYPE (gnu_name))))
4452 gnu_name = convert (gnu_name_type, gnu_name);
4454 /* If this is an In Out or Out parameter and we're returning a value,
4455 we need to create a temporary for the return value because we must
4456 preserve it before copying back at the very end. */
4457 if (!in_param && returning_value && !gnu_retval)
4458 gnu_retval = create_temporary ("R", gnu_result_type);
4460 /* If we haven't pushed a binding level, push a new one. This will
4461 narrow the lifetime of the temporary we are about to make as much
4462 as possible. The drawback is that we'd need to create a temporary
4463 for the return value, if any (see comment before the loop). So do
4464 it only when this temporary was already created just above. */
4465 if (!pushed_binding_level && !(in_param && returning_value))
4467 start_stmt_group ();
4468 gnat_pushlevel ();
4469 pushed_binding_level = true;
4472 /* Create an explicit temporary holding the copy. */
4473 gnu_temp
4474 = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
4476 /* But initialize it on the fly like for an implicit temporary as
4477 we aren't necessarily having a statement list. */
4478 gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
4479 gnu_temp);
4481 /* Set up to move the copy back to the original if needed. */
4482 if (!in_param)
4484 /* If the original is a COND_EXPR whose first arm isn't meant to
4485 be further used, just deal with the second arm. This is very
4486 likely the conditional expression built for a check. */
4487 if (TREE_CODE (gnu_orig) == COND_EXPR
4488 && TREE_CODE (TREE_OPERAND (gnu_orig, 1)) == COMPOUND_EXPR
4489 && integer_zerop
4490 (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
4491 gnu_orig = TREE_OPERAND (gnu_orig, 2);
4493 gnu_stmt
4494 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
4495 set_expr_location_from_node (gnu_stmt, gnat_node);
4497 append_to_statement_list (gnu_stmt, &gnu_after_list);
4501 /* Start from the real object and build the actual. */
4502 gnu_actual = gnu_name;
4504 /* If atomic access is required for an In or In Out actual parameter,
4505 build the atomic load. */
4506 if (is_true_formal_parm
4507 && !is_by_ref_formal_parm
4508 && Ekind (gnat_formal) != E_Out_Parameter
4509 && atomic_access_required_p (gnat_actual, &sync))
4510 gnu_actual = build_atomic_load (gnu_actual, sync);
4512 /* If this was a procedure call, we may not have removed any padding.
4513 So do it here for the part we will use as an input, if any. */
4514 if (Ekind (gnat_formal) != E_Out_Parameter
4515 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4516 gnu_actual
4517 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
4519 /* Put back the conversion we suppressed above in the computation of the
4520 real object. And even if we didn't suppress any conversion there, we
4521 may have suppressed a conversion to the Etype of the actual earlier,
4522 since the parent is a procedure call, so put it back here. */
4523 if (suppress_type_conversion
4524 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4525 gnu_actual
4526 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
4527 gnu_actual, No_Truncation (gnat_actual));
4528 else
4529 gnu_actual
4530 = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
4532 /* Make sure that the actual is in range of the formal's type. */
4533 if (Ekind (gnat_formal) != E_Out_Parameter
4534 && Do_Range_Check (gnat_actual))
4535 gnu_actual
4536 = emit_range_check (gnu_actual, gnat_formal_type, gnat_actual);
4538 /* Unless this is an In parameter, we must remove any justified modular
4539 building from GNU_NAME to get an lvalue. */
4540 if (Ekind (gnat_formal) != E_In_Parameter
4541 && TREE_CODE (gnu_name) == CONSTRUCTOR
4542 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
4543 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
4544 gnu_name
4545 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
4547 /* First see if the parameter is passed by reference. */
4548 if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
4550 if (Ekind (gnat_formal) != E_In_Parameter)
4552 /* In Out or Out parameters passed by reference don't use the
4553 copy-in/copy-out mechanism so the address of the real object
4554 must be passed to the function. */
4555 gnu_actual = gnu_name;
4557 /* If we have a padded type, be sure we've removed padding. */
4558 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4559 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
4560 gnu_actual);
4562 /* If we have the constructed subtype of an aliased object
4563 with an unconstrained nominal subtype, the type of the
4564 actual includes the template, although it is formally
4565 constrained. So we need to convert it back to the real
4566 constructed subtype to retrieve the constrained part
4567 and takes its address. */
4568 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
4569 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
4570 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
4571 && Is_Array_Type (Underlying_Type (Etype (gnat_actual))))
4572 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
4573 gnu_actual);
4576 /* There is no need to convert the actual to the formal's type before
4577 taking its address. The only exception is for unconstrained array
4578 types because of the way we build fat pointers. */
4579 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4581 /* Put back a view conversion for In Out or Out parameters. */
4582 if (Ekind (gnat_formal) != E_In_Parameter)
4583 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
4584 gnu_actual);
4585 gnu_actual = convert (gnu_formal_type, gnu_actual);
4588 /* The symmetry of the paths to the type of an entity is broken here
4589 since arguments don't know that they will be passed by ref. */
4590 gnu_formal_type = TREE_TYPE (gnu_formal);
4591 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4594 /* Then see if the parameter is an array passed to a foreign convention
4595 subprogram. */
4596 else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
4598 gnu_formal_type = TREE_TYPE (gnu_formal);
4599 gnu_actual = maybe_implicit_deref (gnu_actual);
4600 gnu_actual = maybe_unconstrained_array (gnu_actual);
4602 if (TYPE_IS_PADDING_P (gnu_formal_type))
4604 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
4605 gnu_actual = convert (gnu_formal_type, gnu_actual);
4608 /* Take the address of the object and convert to the proper pointer
4609 type. We'd like to actually compute the address of the beginning
4610 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4611 possibility that the ARRAY_REF might return a constant and we'd be
4612 getting the wrong address. Neither approach is exactly correct,
4613 but this is the most likely to work in all cases. */
4614 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4617 /* Otherwise the parameter is passed by copy. */
4618 else
4620 tree gnu_size;
4622 if (Ekind (gnat_formal) != E_In_Parameter)
4623 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
4625 /* If we didn't create a PARM_DECL for the formal, this means that
4626 it is an Out parameter not passed by reference and that need not
4627 be copied in. In this case, the value of the actual need not be
4628 read. However, we still need to make sure that its side-effects
4629 are evaluated before the call, so we evaluate its address. */
4630 if (!is_true_formal_parm)
4632 if (TREE_SIDE_EFFECTS (gnu_name))
4634 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
4635 append_to_statement_list (addr, &gnu_stmt_list);
4637 continue;
4640 gnu_actual = convert (gnu_formal_type, gnu_actual);
4642 /* If this is 'Null_Parameter, pass a zero even though we are
4643 dereferencing it. */
4644 if (TREE_CODE (gnu_actual) == INDIRECT_REF
4645 && TREE_PRIVATE (gnu_actual)
4646 && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
4647 && TREE_CODE (gnu_size) == INTEGER_CST
4648 && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
4649 gnu_actual
4650 = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
4651 convert (gnat_type_for_size
4652 (TREE_INT_CST_LOW (gnu_size), 1),
4653 integer_zero_node),
4654 false);
4655 else
4656 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
4659 vec_safe_push (gnu_actual_vec, gnu_actual);
4662 gnu_call
4663 = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
4664 set_expr_location_from_node (gnu_call, gnat_node);
4666 /* If we have created a temporary for the return value, initialize it. */
4667 if (gnu_retval)
4669 tree gnu_stmt
4670 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
4671 set_expr_location_from_node (gnu_stmt, gnat_node);
4672 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4673 gnu_call = gnu_retval;
4676 /* If this is a subprogram with copy-in/copy-out parameters, we need to
4677 unpack the valued returned from the function into the In Out or Out
4678 parameters. We deal with the function return (if this is an Ada
4679 function) below. */
4680 if (TYPE_CI_CO_LIST (gnu_subprog_type))
4682 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
4683 copy-out parameters. */
4684 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
4685 const int length = list_length (gnu_cico_list);
4687 /* The call sequence must contain one and only one call, even though the
4688 function is pure. Save the result into a temporary if needed. */
4689 if (length > 1)
4691 if (!gnu_retval)
4693 tree gnu_stmt;
4694 /* If we haven't pushed a binding level, push a new one. This
4695 will narrow the lifetime of the temporary we are about to
4696 make as much as possible. */
4697 if (!pushed_binding_level)
4699 start_stmt_group ();
4700 gnat_pushlevel ();
4701 pushed_binding_level = true;
4703 gnu_call
4704 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
4705 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4708 gnu_name_list = nreverse (gnu_name_list);
4711 /* The first entry is for the actual return value if this is a
4712 function, so skip it. */
4713 if (function_call)
4714 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4716 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4717 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4718 else
4719 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4721 for (gnat_actual = First_Actual (gnat_node);
4722 Present (gnat_actual);
4723 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4724 gnat_actual = Next_Actual (gnat_actual))
4725 /* If we are dealing with a copy-in/copy-out parameter, we must
4726 retrieve its value from the record returned in the call. */
4727 if (!(present_gnu_tree (gnat_formal)
4728 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
4729 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
4730 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))))
4731 && Ekind (gnat_formal) != E_In_Parameter)
4733 /* Get the value to assign to this Out or In Out parameter. It is
4734 either the result of the function if there is only a single such
4735 parameter or the appropriate field from the record returned. */
4736 tree gnu_result
4737 = length == 1
4738 ? gnu_call
4739 : build_component_ref (gnu_call, TREE_PURPOSE (gnu_cico_list),
4740 false);
4742 /* If the actual is a conversion, get the inner expression, which
4743 will be the real destination, and convert the result to the
4744 type of the actual parameter. */
4745 tree gnu_actual
4746 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
4748 /* If the result is a padded type, remove the padding. */
4749 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4750 gnu_result
4751 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4752 gnu_result);
4754 /* If the actual is a type conversion, the real target object is
4755 denoted by the inner Expression and we need to convert the
4756 result to the associated type.
4757 We also need to convert our gnu assignment target to this type
4758 if the corresponding GNU_NAME was constructed from the GNAT
4759 conversion node and not from the inner Expression. */
4760 if (Nkind (gnat_actual) == N_Type_Conversion)
4762 gnu_result
4763 = convert_with_check
4764 (Etype (Expression (gnat_actual)), gnu_result,
4765 Do_Overflow_Check (gnat_actual),
4766 Do_Range_Check (Expression (gnat_actual)),
4767 Float_Truncate (gnat_actual), gnat_actual);
4769 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
4770 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
4773 /* Unchecked conversions as actuals for Out parameters are not
4774 allowed in user code because they are not variables, but do
4775 occur in front-end expansions. The associated GNU_NAME is
4776 always obtained from the inner expression in such cases. */
4777 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4778 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
4779 gnu_result,
4780 No_Truncation (gnat_actual));
4781 else
4783 if (Do_Range_Check (gnat_actual))
4784 gnu_result
4785 = emit_range_check (gnu_result, Etype (gnat_actual),
4786 gnat_actual);
4788 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
4789 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
4790 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
4793 /* If an outer atomic access is required for an actual parameter,
4794 build the load-modify-store sequence. */
4795 if (outer_atomic_access_required_p (gnat_actual))
4796 gnu_result
4797 = build_load_modify_store (gnu_actual, gnu_result, gnat_node);
4799 /* Or else, if simple atomic access is required, build the atomic
4800 store. */
4801 else if (atomic_access_required_p (gnat_actual, &sync))
4802 gnu_result = build_atomic_store (gnu_actual, gnu_result, sync);
4804 /* Otherwise build a regular assignment. */
4805 else
4806 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
4807 gnu_actual, gnu_result);
4809 if (EXPR_P (gnu_result))
4810 set_expr_location_from_node (gnu_result, gnat_node);
4811 append_to_statement_list (gnu_result, &gnu_stmt_list);
4812 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4813 gnu_name_list = TREE_CHAIN (gnu_name_list);
4817 /* If this is a function call, the result is the call expression unless a
4818 target is specified, in which case we copy the result into the target
4819 and return the assignment statement. */
4820 if (function_call)
4822 /* If this is a function with copy-in/copy-out parameters, extract the
4823 return value from it and update the return type. */
4824 if (TYPE_CI_CO_LIST (gnu_subprog_type))
4826 tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
4827 gnu_call
4828 = build_component_ref (gnu_call, TREE_PURPOSE (gnu_elmt), false);
4829 gnu_result_type = TREE_TYPE (gnu_call);
4832 /* If the function returns an unconstrained array or by direct reference,
4833 we have to dereference the pointer. */
4834 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
4835 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
4836 gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
4838 if (gnu_target)
4840 Node_Id gnat_parent = Parent (gnat_node);
4841 enum tree_code op_code;
4843 /* If range check is needed, emit code to generate it. */
4844 if (Do_Range_Check (gnat_node))
4845 gnu_call
4846 = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
4847 gnat_parent);
4849 /* ??? If the return type has variable size, then force the return
4850 slot optimization as we would not be able to create a temporary.
4851 That's what has been done historically. */
4852 if (return_type_with_variable_size_p (gnu_result_type))
4853 op_code = INIT_EXPR;
4854 else
4855 op_code = MODIFY_EXPR;
4857 /* Use the required method to move the result to the target. */
4858 if (outer_atomic_access)
4859 gnu_call
4860 = build_load_modify_store (gnu_target, gnu_call, gnat_node);
4861 else if (atomic_access)
4862 gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
4863 else
4864 gnu_call
4865 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
4867 if (EXPR_P (gnu_call))
4868 set_expr_location_from_node (gnu_call, gnat_parent);
4869 append_to_statement_list (gnu_call, &gnu_stmt_list);
4871 else
4872 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
4875 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
4876 parameters, the result is just the call statement. */
4877 else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
4878 append_to_statement_list (gnu_call, &gnu_stmt_list);
4880 /* Finally, add the copy back statements, if any. */
4881 append_to_statement_list (gnu_after_list, &gnu_stmt_list);
4883 if (went_into_elab_proc)
4884 current_function_decl = NULL_TREE;
4886 /* If we have pushed a binding level, pop it and finish up the enclosing
4887 statement group. */
4888 if (pushed_binding_level)
4890 add_stmt (gnu_stmt_list);
4891 gnat_poplevel ();
4892 gnu_result = end_stmt_group ();
4895 /* Otherwise, retrieve the statement list, if any. */
4896 else if (gnu_stmt_list)
4897 gnu_result = gnu_stmt_list;
4899 /* Otherwise, just return the call expression. */
4900 else
4901 return gnu_call;
4903 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
4904 But first simplify if we have only one statement in the list. */
4905 if (returning_value)
4907 tree first = expr_first (gnu_result), last = expr_last (gnu_result);
4908 if (first == last)
4909 gnu_result = first;
4910 gnu_result
4911 = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
4914 return gnu_result;
4917 /* Subroutine of gnat_to_gnu to translate gnat_node, an
4918 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
4920 static tree
4921 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
4923 tree gnu_jmpsave_decl = NULL_TREE;
4924 tree gnu_jmpbuf_decl = NULL_TREE;
4925 /* If just annotating, ignore all EH and cleanups. */
4926 bool gcc_zcx = (!type_annotate_only
4927 && Present (Exception_Handlers (gnat_node))
4928 && Exception_Mechanism == Back_End_Exceptions);
4929 bool setjmp_longjmp
4930 = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
4931 && Exception_Mechanism == Setjmp_Longjmp);
4932 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
4933 bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
4934 tree gnu_inner_block; /* The statement(s) for the block itself. */
4935 tree gnu_result;
4936 tree gnu_expr;
4937 Node_Id gnat_temp;
4938 /* Node providing the sloc for the cleanup actions. */
4939 Node_Id gnat_cleanup_loc_node = (Present (End_Label (gnat_node)) ?
4940 End_Label (gnat_node) :
4941 gnat_node);
4943 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
4944 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
4945 add_cleanup, and when we leave the binding, end_stmt_group will create
4946 the TRY_FINALLY_EXPR.
4948 ??? The region level calls down there have been specifically put in place
4949 for a ZCX context and currently the order in which things are emitted
4950 (region/handlers) is different from the SJLJ case. Instead of putting
4951 other calls with different conditions at other places for the SJLJ case,
4952 it seems cleaner to reorder things for the SJLJ case and generalize the
4953 condition to make it not ZCX specific.
4955 If there are any exceptions or cleanup processing involved, we need an
4956 outer statement group (for Setjmp_Longjmp) and binding level. */
4957 if (binding_for_block)
4959 start_stmt_group ();
4960 gnat_pushlevel ();
4963 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
4964 area for address of previous buffer. Do this first since we need to have
4965 the setjmp buf known for any decls in this block. */
4966 if (setjmp_longjmp)
4968 gnu_jmpsave_decl
4969 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
4970 jmpbuf_ptr_type,
4971 build_call_n_expr (get_jmpbuf_decl, 0),
4972 false, false, false, false, true, false,
4973 NULL, gnat_node);
4975 /* The __builtin_setjmp receivers will immediately reinstall it. Now
4976 because of the unstructured form of EH used by setjmp_longjmp, there
4977 might be forward edges going to __builtin_setjmp receivers on which
4978 it is uninitialized, although they will never be actually taken. */
4979 TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
4980 gnu_jmpbuf_decl
4981 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
4982 jmpbuf_type,
4983 NULL_TREE,
4984 false, false, false, false, true, false,
4985 NULL, gnat_node);
4987 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
4989 /* When we exit this block, restore the saved value. */
4990 add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
4991 gnat_cleanup_loc_node);
4994 /* If we are to call a function when exiting this block, add a cleanup
4995 to the binding level we made above. Note that add_cleanup is FIFO
4996 so we must register this cleanup after the EH cleanup just above. */
4997 if (at_end)
4999 tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
5000 /* When not optimizing, disable inlining of finalizers as this can
5001 create a more complex CFG in the parent function. */
5002 if (!optimize)
5003 DECL_DECLARED_INLINE_P (proc_decl) = 0;
5004 add_cleanup (build_call_n_expr (proc_decl, 0), gnat_cleanup_loc_node);
5007 /* Now build the tree for the declarations and statements inside this block.
5008 If this is SJLJ, set our jmp_buf as the current buffer. */
5009 start_stmt_group ();
5011 if (setjmp_longjmp)
5013 gnu_expr = build_call_n_expr (set_jmpbuf_decl, 1,
5014 build_unary_op (ADDR_EXPR, NULL_TREE,
5015 gnu_jmpbuf_decl));
5016 set_expr_location_from_node (gnu_expr, gnat_node);
5017 add_stmt (gnu_expr);
5020 if (Present (First_Real_Statement (gnat_node)))
5021 process_decls (Statements (gnat_node), Empty,
5022 First_Real_Statement (gnat_node), true, true);
5024 /* Generate code for each statement in the block. */
5025 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
5026 ? First_Real_Statement (gnat_node)
5027 : First (Statements (gnat_node)));
5028 Present (gnat_temp); gnat_temp = Next (gnat_temp))
5029 add_stmt (gnat_to_gnu (gnat_temp));
5030 gnu_inner_block = end_stmt_group ();
5032 /* Now generate code for the two exception models, if either is relevant for
5033 this block. */
5034 if (setjmp_longjmp)
5036 tree *gnu_else_ptr = 0;
5037 tree gnu_handler;
5039 /* Make a binding level for the exception handling declarations and code
5040 and set up gnu_except_ptr_stack for the handlers to use. */
5041 start_stmt_group ();
5042 gnat_pushlevel ();
5044 vec_safe_push (gnu_except_ptr_stack,
5045 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
5046 build_pointer_type (except_type_node),
5047 build_call_n_expr (get_excptr_decl, 0),
5048 false, false, false, false, true, false,
5049 NULL, gnat_node));
5051 /* Generate code for each handler. The N_Exception_Handler case does the
5052 real work and returns a COND_EXPR for each handler, which we chain
5053 together here. */
5054 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5055 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
5057 gnu_expr = gnat_to_gnu (gnat_temp);
5059 /* If this is the first one, set it as the outer one. Otherwise,
5060 point the "else" part of the previous handler to us. Then point
5061 to our "else" part. */
5062 if (!gnu_else_ptr)
5063 add_stmt (gnu_expr);
5064 else
5065 *gnu_else_ptr = gnu_expr;
5067 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
5070 /* If none of the exception handlers did anything, re-raise but do not
5071 defer abortion. */
5072 gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
5073 gnu_except_ptr_stack->last ());
5074 set_expr_location_from_node
5075 (gnu_expr,
5076 Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
5078 if (gnu_else_ptr)
5079 *gnu_else_ptr = gnu_expr;
5080 else
5081 add_stmt (gnu_expr);
5083 /* End the binding level dedicated to the exception handlers and get the
5084 whole statement group. */
5085 gnu_except_ptr_stack->pop ();
5086 gnat_poplevel ();
5087 gnu_handler = end_stmt_group ();
5089 /* If the setjmp returns 1, we restore our incoming longjmp value and
5090 then check the handlers. */
5091 start_stmt_group ();
5092 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1,
5093 gnu_jmpsave_decl),
5094 gnat_node);
5095 add_stmt (gnu_handler);
5096 gnu_handler = end_stmt_group ();
5098 /* This block is now "if (setjmp) ... <handlers> else <block>". */
5099 gnu_result = build3 (COND_EXPR, void_type_node,
5100 (build_call_n_expr
5101 (setjmp_decl, 1,
5102 build_unary_op (ADDR_EXPR, NULL_TREE,
5103 gnu_jmpbuf_decl))),
5104 gnu_handler, gnu_inner_block);
5106 else if (gcc_zcx)
5108 tree gnu_handlers;
5109 location_t locus;
5111 /* First make a block containing the handlers. */
5112 start_stmt_group ();
5113 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5114 Present (gnat_temp);
5115 gnat_temp = Next_Non_Pragma (gnat_temp))
5116 add_stmt (gnat_to_gnu (gnat_temp));
5117 gnu_handlers = end_stmt_group ();
5119 /* Now make the TRY_CATCH_EXPR for the block. */
5120 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
5121 gnu_inner_block, gnu_handlers);
5122 /* Set a location. We need to find a unique location for the dispatching
5123 code, otherwise we can get coverage or debugging issues. Try with
5124 the location of the end label. */
5125 if (Present (End_Label (gnat_node))
5126 && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus))
5127 SET_EXPR_LOCATION (gnu_result, locus);
5128 else
5129 /* Clear column information so that the exception handler of an
5130 implicit transient block does not incorrectly inherit the slocs
5131 of a decision, which would otherwise confuse control flow based
5132 coverage analysis tools. */
5133 set_expr_location_from_node (gnu_result, gnat_node, true);
5135 else
5136 gnu_result = gnu_inner_block;
5138 /* Now close our outer block, if we had to make one. */
5139 if (binding_for_block)
5141 add_stmt (gnu_result);
5142 gnat_poplevel ();
5143 gnu_result = end_stmt_group ();
5146 return gnu_result;
5149 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5150 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
5151 exception handling. */
5153 static tree
5154 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
5156 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5157 an "if" statement to select the proper exceptions. For "Others", exclude
5158 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5159 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5160 tree gnu_choice = boolean_false_node;
5161 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
5162 Node_Id gnat_temp;
5164 for (gnat_temp = First (Exception_Choices (gnat_node));
5165 gnat_temp; gnat_temp = Next (gnat_temp))
5167 tree this_choice;
5169 if (Nkind (gnat_temp) == N_Others_Choice)
5171 if (All_Others (gnat_temp))
5172 this_choice = boolean_true_node;
5173 else
5174 this_choice
5175 = build_binary_op
5176 (EQ_EXPR, boolean_type_node,
5177 convert
5178 (integer_type_node,
5179 build_component_ref
5180 (build_unary_op
5181 (INDIRECT_REF, NULL_TREE,
5182 gnu_except_ptr_stack->last ()),
5183 not_handled_by_others_decl,
5184 false)),
5185 integer_zero_node);
5188 else if (Nkind (gnat_temp) == N_Identifier
5189 || Nkind (gnat_temp) == N_Expanded_Name)
5191 Entity_Id gnat_ex_id = Entity (gnat_temp);
5192 tree gnu_expr;
5194 /* Exception may be a renaming. Recover original exception which is
5195 the one elaborated and registered. */
5196 if (Present (Renamed_Object (gnat_ex_id)))
5197 gnat_ex_id = Renamed_Object (gnat_ex_id);
5199 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
5201 this_choice
5202 = build_binary_op
5203 (EQ_EXPR, boolean_type_node,
5204 gnu_except_ptr_stack->last (),
5205 convert (TREE_TYPE (gnu_except_ptr_stack->last ()),
5206 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
5208 else
5209 gcc_unreachable ();
5211 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
5212 gnu_choice, this_choice);
5215 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
5218 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5219 to a GCC tree, which is returned. This is the variant for ZCX. */
5221 static tree
5222 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
5224 tree gnu_etypes_list = NULL_TREE;
5225 tree gnu_current_exc_ptr, prev_gnu_incoming_exc_ptr;
5226 Node_Id gnat_temp;
5228 /* We build a TREE_LIST of nodes representing what exception types this
5229 handler can catch, with special cases for others and all others cases.
5231 Each exception type is actually identified by a pointer to the exception
5232 id, or to a dummy object for "others" and "all others". */
5233 for (gnat_temp = First (Exception_Choices (gnat_node));
5234 gnat_temp; gnat_temp = Next (gnat_temp))
5236 tree gnu_expr, gnu_etype;
5238 if (Nkind (gnat_temp) == N_Others_Choice)
5240 gnu_expr = All_Others (gnat_temp) ? all_others_decl : others_decl;
5241 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5243 else if (Nkind (gnat_temp) == N_Identifier
5244 || Nkind (gnat_temp) == N_Expanded_Name)
5246 Entity_Id gnat_ex_id = Entity (gnat_temp);
5248 /* Exception may be a renaming. Recover original exception which is
5249 the one elaborated and registered. */
5250 if (Present (Renamed_Object (gnat_ex_id)))
5251 gnat_ex_id = Renamed_Object (gnat_ex_id);
5253 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
5254 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5256 else
5257 gcc_unreachable ();
5259 /* The GCC interface expects NULL to be passed for catch all handlers, so
5260 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5261 is integer_zero_node. It would not work, however, because GCC's
5262 notion of "catch all" is stronger than our notion of "others". Until
5263 we correctly use the cleanup interface as well, doing that would
5264 prevent the "all others" handlers from being seen, because nothing
5265 can be caught beyond a catch all from GCC's point of view. */
5266 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
5269 start_stmt_group ();
5270 gnat_pushlevel ();
5272 /* Expand a call to the begin_handler hook at the beginning of the handler,
5273 and arrange for a call to the end_handler hook to occur on every possible
5274 exit path.
5276 The hooks expect a pointer to the low level occurrence. This is required
5277 for our stack management scheme because a raise inside the handler pushes
5278 a new occurrence on top of the stack, which means that this top does not
5279 necessarily match the occurrence this handler was dealing with.
5281 __builtin_eh_pointer references the exception occurrence being
5282 propagated. Upon handler entry, this is the exception for which the
5283 handler is triggered. This might not be the case upon handler exit,
5284 however, as we might have a new occurrence propagated by the handler's
5285 body, and the end_handler hook called as a cleanup in this context.
5287 We use a local variable to retrieve the incoming value at handler entry
5288 time, and reuse it to feed the end_handler hook's argument at exit. */
5290 gnu_current_exc_ptr
5291 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
5292 1, integer_zero_node);
5293 prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
5294 gnu_incoming_exc_ptr
5295 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
5296 ptr_type_node, gnu_current_exc_ptr,
5297 false, false, false, false, true, true,
5298 NULL, gnat_node);
5300 add_stmt_with_node (build_call_n_expr (begin_handler_decl, 1,
5301 gnu_incoming_exc_ptr),
5302 gnat_node);
5304 /* Declare and initialize the choice parameter, if present. */
5305 if (Present (Choice_Parameter (gnat_node)))
5307 tree gnu_param
5308 = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, 1);
5310 add_stmt (build_call_n_expr
5311 (set_exception_parameter_decl, 2,
5312 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param),
5313 gnu_incoming_exc_ptr));
5316 /* We don't have an End_Label at hand to set the location of the cleanup
5317 actions, so we use that of the exception handler itself instead. */
5318 add_cleanup (build_call_n_expr (end_handler_decl, 1, gnu_incoming_exc_ptr),
5319 gnat_node);
5320 add_stmt_list (Statements (gnat_node));
5321 gnat_poplevel ();
5323 gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
5325 return
5326 build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ());
5329 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5331 static void
5332 Compilation_Unit_to_gnu (Node_Id gnat_node)
5334 const Node_Id gnat_unit = Unit (gnat_node);
5335 const bool body_p = (Nkind (gnat_unit) == N_Package_Body
5336 || Nkind (gnat_unit) == N_Subprogram_Body);
5337 const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
5338 Entity_Id gnat_entity;
5339 Node_Id gnat_pragma;
5340 /* Make the decl for the elaboration procedure. */
5341 tree gnu_elab_proc_decl
5342 = create_subprog_decl
5343 (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
5344 NULL_TREE, void_ftype, NULL_TREE, is_disabled, true, false, true, true,
5345 NULL, gnat_unit);
5346 struct elab_info *info;
5348 vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
5349 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
5351 /* Initialize the information structure for the function. */
5352 allocate_struct_function (gnu_elab_proc_decl, false);
5353 set_cfun (NULL);
5355 current_function_decl = NULL_TREE;
5357 start_stmt_group ();
5358 gnat_pushlevel ();
5360 /* For a body, first process the spec if there is one. */
5361 if (Nkind (gnat_unit) == N_Package_Body
5362 || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
5363 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
5365 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
5367 elaborate_all_entities (gnat_node);
5369 if (Nkind (gnat_unit) == N_Subprogram_Declaration
5370 || Nkind (gnat_unit) == N_Generic_Package_Declaration
5371 || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
5372 return;
5375 /* Then process any pragmas and declarations preceding the unit. */
5376 for (gnat_pragma = First (Context_Items (gnat_node));
5377 Present (gnat_pragma);
5378 gnat_pragma = Next (gnat_pragma))
5379 if (Nkind (gnat_pragma) == N_Pragma)
5380 add_stmt (gnat_to_gnu (gnat_pragma));
5381 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
5382 true, true);
5384 /* Process the unit itself. */
5385 add_stmt (gnat_to_gnu (gnat_unit));
5387 /* Generate code for all the inlined subprograms. */
5388 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5389 Present (gnat_entity);
5390 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5392 Node_Id gnat_body;
5394 /* Without optimization, process only the required subprograms. */
5395 if (!optimize && !Has_Pragma_Inline_Always (gnat_entity))
5396 continue;
5398 gnat_body = Parent (Declaration_Node (gnat_entity));
5399 if (Nkind (gnat_body) != N_Subprogram_Body)
5401 /* ??? This happens when only the spec of a package is provided. */
5402 if (No (Corresponding_Body (gnat_body)))
5403 continue;
5405 gnat_body
5406 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5409 /* Define the entity first so we set DECL_EXTERNAL. */
5410 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5411 add_stmt (gnat_to_gnu (gnat_body));
5414 /* Process any pragmas and actions following the unit. */
5415 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
5416 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
5417 finalize_from_limited_with ();
5419 /* Save away what we've made so far and finish it up. */
5420 set_current_block_context (gnu_elab_proc_decl);
5421 gnat_poplevel ();
5422 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
5423 set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
5424 gnu_elab_proc_stack->pop ();
5426 /* Record this potential elaboration procedure for later processing. */
5427 info = ggc_alloc<elab_info> ();
5428 info->next = elab_info_list;
5429 info->elab_proc = gnu_elab_proc_decl;
5430 info->gnat_node = gnat_node;
5431 elab_info_list = info;
5433 /* Force the processing for all nodes that remain in the queue. */
5434 process_deferred_decl_context (true);
5437 /* Mark COND, a boolean expression, as predicating a call to a noreturn
5438 function, i.e. predict that it is very likely false, and return it.
5440 The compiler will automatically predict the last edge leading to a call
5441 to a noreturn function as very unlikely taken. This function makes it
5442 possible to expand the prediction to predecessors in case the condition
5443 is made up of several short-circuit operators. */
5445 static tree
5446 build_noreturn_cond (tree cond)
5448 tree fn = builtin_decl_explicit (BUILT_IN_EXPECT);
5449 tree arg_types = TYPE_ARG_TYPES (TREE_TYPE (fn));
5450 tree pred_type = TREE_VALUE (arg_types);
5451 tree expected_type = TREE_VALUE (TREE_CHAIN (arg_types));
5453 tree t = build_call_expr (fn, 3,
5454 fold_convert (pred_type, cond),
5455 build_int_cst (expected_type, 0),
5456 build_int_cst (integer_type_node,
5457 PRED_NORETURN));
5459 return build1 (NOP_EXPR, boolean_type_node, t);
5462 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Raise_xxx_Error,
5463 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where
5464 we should place the result type. LABEL_P is true if there is a label to
5465 branch to for the exception. */
5467 static tree
5468 Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
5470 const Node_Kind kind = Nkind (gnat_node);
5471 const int reason = UI_To_Int (Reason (gnat_node));
5472 const Node_Id gnat_cond = Condition (gnat_node);
5473 const bool with_extra_info
5474 = Exception_Extra_Info
5475 && !No_Exception_Handlers_Set ()
5476 && !get_exception_label (kind);
5477 tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
5479 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
5481 switch (reason)
5483 case CE_Access_Check_Failed:
5484 if (with_extra_info)
5485 gnu_result = build_call_raise_column (reason, gnat_node);
5486 break;
5488 case CE_Index_Check_Failed:
5489 case CE_Range_Check_Failed:
5490 case CE_Invalid_Data:
5491 if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
5493 Node_Id gnat_range, gnat_index, gnat_type;
5494 tree gnu_index, gnu_low_bound, gnu_high_bound;
5495 struct loop_info_d *loop;
5497 switch (Nkind (Right_Opnd (gnat_cond)))
5499 case N_In:
5500 gnat_range = Right_Opnd (Right_Opnd (gnat_cond));
5501 gcc_assert (Nkind (gnat_range) == N_Range);
5502 gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range));
5503 gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range));
5504 break;
5506 case N_Op_Ge:
5507 gnu_low_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
5508 gnu_high_bound = NULL_TREE;
5509 break;
5511 case N_Op_Le:
5512 gnu_low_bound = NULL_TREE;
5513 gnu_high_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
5514 break;
5516 default:
5517 goto common;
5520 gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
5521 gnat_type = Etype (gnat_index);
5522 gnu_index = gnat_to_gnu (gnat_index);
5524 if (with_extra_info
5525 && gnu_low_bound
5526 && gnu_high_bound
5527 && Known_Esize (gnat_type)
5528 && UI_To_Int (Esize (gnat_type)) <= 32)
5529 gnu_result
5530 = build_call_raise_range (reason, gnat_node, gnu_index,
5531 gnu_low_bound, gnu_high_bound);
5533 /* If optimization is enabled and we are inside a loop, we try to
5534 compute invariant conditions for checks applied to the iteration
5535 variable, i.e. conditions that are independent of the variable
5536 and necessary in order for the checks to fail in the course of
5537 some iteration. If we succeed, we consider an alternative:
5539 1. If loop unswitching is enabled, we prepend these conditions
5540 to the original conditions of the checks. This will make it
5541 possible for the loop unswitching pass to replace the loop
5542 with two loops, one of which has the checks eliminated and
5543 the other has the original checks reinstated, and a prologue
5544 implementing a run-time selection. The former loop will be
5545 for example suitable for vectorization.
5547 2. Otherwise, we instead append the conditions to the original
5548 conditions of the checks. At worse, if the conditions cannot
5549 be evaluated at compile time, they will be evaluated as true
5550 at run time only when the checks have already failed, thus
5551 contributing negatively only to the size of the executable.
5552 But the hope is that these invariant conditions be evaluated
5553 at compile time to false, thus taking away the entire checks
5554 with them. */
5555 if (optimize
5556 && inside_loop_p ()
5557 && (!gnu_low_bound
5558 || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)))
5559 && (!gnu_high_bound
5560 || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)))
5561 && (loop = find_loop_for (gnu_index)))
5563 struct range_check_info_d *rci = ggc_alloc<range_check_info_d> ();
5564 rci->low_bound = gnu_low_bound;
5565 rci->high_bound = gnu_high_bound;
5566 rci->type = get_unpadded_type (gnat_type);
5567 rci->inserted_cond
5568 = build1 (SAVE_EXPR, boolean_type_node, boolean_true_node);
5569 vec_safe_push (loop->checks, rci);
5570 loop->has_checks = true;
5571 gnu_cond = build_noreturn_cond (gnat_to_gnu (gnat_cond));
5572 if (flag_unswitch_loops)
5573 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
5574 boolean_type_node,
5575 rci->inserted_cond,
5576 gnu_cond);
5577 else
5578 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
5579 boolean_type_node,
5580 gnu_cond,
5581 rci->inserted_cond);
5584 /* Or else, if aggressive loop optimizations are enabled, we just
5585 record that there are checks applied to iteration variables. */
5586 else if (optimize
5587 && flag_aggressive_loop_optimizations
5588 && inside_loop_p ()
5589 && (loop = find_loop_for (gnu_index)))
5590 loop->has_checks = true;
5592 break;
5594 default:
5595 break;
5598 common:
5599 if (!gnu_result)
5600 gnu_result = build_call_raise (reason, gnat_node, kind);
5601 set_expr_location_from_node (gnu_result, gnat_node);
5603 /* If the type is VOID, this is a statement, so we need to generate the code
5604 for the call. Handle a condition, if there is one. */
5605 if (VOID_TYPE_P (*gnu_result_type_p))
5607 if (Present (gnat_cond))
5609 if (!gnu_cond)
5610 gnu_cond = gnat_to_gnu (gnat_cond);
5611 gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
5612 alloc_stmt_list ());
5615 else
5616 gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
5618 return gnu_result;
5621 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
5622 parameter of a call. */
5624 static bool
5625 lhs_or_actual_p (Node_Id gnat_node)
5627 Node_Id gnat_parent = Parent (gnat_node);
5628 Node_Kind kind = Nkind (gnat_parent);
5630 if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
5631 return true;
5633 if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
5634 && Name (gnat_parent) != gnat_node)
5635 return true;
5637 if (kind == N_Parameter_Association)
5638 return true;
5640 return false;
5643 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
5644 of an assignment or an actual parameter of a call. */
5646 static bool
5647 present_in_lhs_or_actual_p (Node_Id gnat_node)
5649 Node_Kind kind;
5651 if (lhs_or_actual_p (gnat_node))
5652 return true;
5654 kind = Nkind (Parent (gnat_node));
5656 if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
5657 && lhs_or_actual_p (Parent (gnat_node)))
5658 return true;
5660 return false;
5663 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
5664 as gigi is concerned. This is used to avoid conversions on the LHS. */
5666 static bool
5667 unchecked_conversion_nop (Node_Id gnat_node)
5669 Entity_Id from_type, to_type;
5671 /* The conversion must be on the LHS of an assignment or an actual parameter
5672 of a call. Otherwise, even if the conversion was essentially a no-op, it
5673 could de facto ensure type consistency and this should be preserved. */
5674 if (!lhs_or_actual_p (gnat_node))
5675 return false;
5677 from_type = Etype (Expression (gnat_node));
5679 /* We're interested in artificial conversions generated by the front-end
5680 to make private types explicit, e.g. in Expand_Assign_Array. */
5681 if (!Is_Private_Type (from_type))
5682 return false;
5684 from_type = Underlying_Type (from_type);
5685 to_type = Etype (gnat_node);
5687 /* The direct conversion to the underlying type is a no-op. */
5688 if (to_type == from_type)
5689 return true;
5691 /* For an array subtype, the conversion to the PAIT is a no-op. */
5692 if (Ekind (from_type) == E_Array_Subtype
5693 && to_type == Packed_Array_Impl_Type (from_type))
5694 return true;
5696 /* For a record subtype, the conversion to the type is a no-op. */
5697 if (Ekind (from_type) == E_Record_Subtype
5698 && to_type == Etype (from_type))
5699 return true;
5701 return false;
5704 /* This function is the driver of the GNAT to GCC tree transformation process.
5705 It is the entry point of the tree transformer. GNAT_NODE is the root of
5706 some GNAT tree. Return the root of the corresponding GCC tree. If this
5707 is an expression, return the GCC equivalent of the expression. If this
5708 is a statement, return the statement or add it to the current statement
5709 group, in which case anything returned is to be interpreted as occurring
5710 after anything added. */
5712 tree
5713 gnat_to_gnu (Node_Id gnat_node)
5715 const Node_Kind kind = Nkind (gnat_node);
5716 bool went_into_elab_proc = false;
5717 tree gnu_result = error_mark_node; /* Default to no value. */
5718 tree gnu_result_type = void_type_node;
5719 tree gnu_expr, gnu_lhs, gnu_rhs;
5720 Node_Id gnat_temp;
5721 bool sync;
5723 /* Save node number for error message and set location information. */
5724 error_gnat_node = gnat_node;
5725 Sloc_to_locus (Sloc (gnat_node), &input_location);
5727 /* If this node is a statement and we are only annotating types, return an
5728 empty statement list. */
5729 if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
5730 return alloc_stmt_list ();
5732 /* If this node is a non-static subexpression and we are only annotating
5733 types, make this into a NULL_EXPR. */
5734 if (type_annotate_only
5735 && IN (kind, N_Subexpr)
5736 && kind != N_Identifier
5737 && !Compile_Time_Known_Value (gnat_node))
5738 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
5739 build_call_raise (CE_Range_Check_Failed, gnat_node,
5740 N_Raise_Constraint_Error));
5742 if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
5743 && kind != N_Null_Statement)
5744 || kind == N_Procedure_Call_Statement
5745 || kind == N_Label
5746 || kind == N_Implicit_Label_Declaration
5747 || kind == N_Handled_Sequence_Of_Statements
5748 || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
5750 tree current_elab_proc = get_elaboration_procedure ();
5752 /* If this is a statement and we are at top level, it must be part of
5753 the elaboration procedure, so mark us as being in that procedure. */
5754 if (!current_function_decl)
5756 current_function_decl = current_elab_proc;
5757 went_into_elab_proc = true;
5760 /* If we are in the elaboration procedure, check if we are violating a
5761 No_Elaboration_Code restriction by having a statement there. Don't
5762 check for a possible No_Elaboration_Code restriction violation on
5763 N_Handled_Sequence_Of_Statements, as we want to signal an error on
5764 every nested real statement instead. This also avoids triggering
5765 spurious errors on dummy (empty) sequences created by the front-end
5766 for package bodies in some cases. */
5767 if (current_function_decl == current_elab_proc
5768 && kind != N_Handled_Sequence_Of_Statements)
5769 Check_Elaboration_Code_Allowed (gnat_node);
5772 switch (kind)
5774 /********************************/
5775 /* Chapter 2: Lexical Elements */
5776 /********************************/
5778 case N_Identifier:
5779 case N_Expanded_Name:
5780 case N_Operator_Symbol:
5781 case N_Defining_Identifier:
5782 case N_Defining_Operator_Symbol:
5783 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
5785 /* If atomic access is required on the RHS, build the atomic load. */
5786 if (atomic_access_required_p (gnat_node, &sync)
5787 && !present_in_lhs_or_actual_p (gnat_node))
5788 gnu_result = build_atomic_load (gnu_result, sync);
5789 break;
5791 case N_Integer_Literal:
5793 tree gnu_type;
5795 /* Get the type of the result, looking inside any padding and
5796 justified modular types. Then get the value in that type. */
5797 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
5799 if (TREE_CODE (gnu_type) == RECORD_TYPE
5800 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
5801 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
5803 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
5805 /* If the result overflows (meaning it doesn't fit in its base type),
5806 abort. We would like to check that the value is within the range
5807 of the subtype, but that causes problems with subtypes whose usage
5808 will raise Constraint_Error and with biased representation, so
5809 we don't. */
5810 gcc_assert (!TREE_OVERFLOW (gnu_result));
5812 break;
5814 case N_Character_Literal:
5815 /* If a Entity is present, it means that this was one of the
5816 literals in a user-defined character type. In that case,
5817 just return the value in the CONST_DECL. Otherwise, use the
5818 character code. In that case, the base type should be an
5819 INTEGER_TYPE, but we won't bother checking for that. */
5820 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5821 if (Present (Entity (gnat_node)))
5822 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
5823 else
5824 gnu_result
5825 = build_int_cst_type
5826 (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
5827 break;
5829 case N_Real_Literal:
5830 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5832 /* If this is of a fixed-point type, the value we want is the value of
5833 the corresponding integer. */
5834 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
5836 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
5837 gnu_result_type);
5838 gcc_assert (!TREE_OVERFLOW (gnu_result));
5841 else
5843 Ureal ur_realval = Realval (gnat_node);
5845 /* First convert the value to a machine number if it isn't already.
5846 That will force the base to 2 for non-zero values and simplify
5847 the rest of the logic. */
5848 if (!Is_Machine_Number (gnat_node))
5849 ur_realval
5850 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
5851 ur_realval, Round_Even, gnat_node);
5853 if (UR_Is_Zero (ur_realval))
5854 gnu_result = convert (gnu_result_type, integer_zero_node);
5855 else
5857 REAL_VALUE_TYPE tmp;
5859 gnu_result = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
5861 /* The base must be 2 as Machine guarantees this, so we scale
5862 the value, which we know can fit in the mantissa of the type
5863 (hence the use of that type above). */
5864 gcc_assert (Rbase (ur_realval) == 2);
5865 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
5866 - UI_To_Int (Denominator (ur_realval)));
5867 gnu_result = build_real (gnu_result_type, tmp);
5870 /* Now see if we need to negate the result. Do it this way to
5871 properly handle -0. */
5872 if (UR_Is_Negative (Realval (gnat_node)))
5873 gnu_result
5874 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
5875 gnu_result);
5878 break;
5880 case N_String_Literal:
5881 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5882 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
5884 String_Id gnat_string = Strval (gnat_node);
5885 int length = String_Length (gnat_string);
5886 int i;
5887 char *string;
5888 if (length >= ALLOCA_THRESHOLD)
5889 string = XNEWVEC (char, length + 1);
5890 else
5891 string = (char *) alloca (length + 1);
5893 /* Build the string with the characters in the literal. Note
5894 that Ada strings are 1-origin. */
5895 for (i = 0; i < length; i++)
5896 string[i] = Get_String_Char (gnat_string, i + 1);
5898 /* Put a null at the end of the string in case it's in a context
5899 where GCC will want to treat it as a C string. */
5900 string[i] = 0;
5902 gnu_result = build_string (length, string);
5904 /* Strings in GCC don't normally have types, but we want
5905 this to not be converted to the array type. */
5906 TREE_TYPE (gnu_result) = gnu_result_type;
5908 if (length >= ALLOCA_THRESHOLD)
5909 free (string);
5911 else
5913 /* Build a list consisting of each character, then make
5914 the aggregate. */
5915 String_Id gnat_string = Strval (gnat_node);
5916 int length = String_Length (gnat_string);
5917 int i;
5918 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
5919 tree gnu_one_node = convert (TREE_TYPE (gnu_idx), integer_one_node);
5920 vec<constructor_elt, va_gc> *gnu_vec;
5921 vec_alloc (gnu_vec, length);
5923 for (i = 0; i < length; i++)
5925 tree t = build_int_cst (TREE_TYPE (gnu_result_type),
5926 Get_String_Char (gnat_string, i + 1));
5928 CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
5929 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, gnu_one_node);
5932 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
5934 break;
5936 case N_Pragma:
5937 gnu_result = Pragma_to_gnu (gnat_node);
5938 break;
5940 /**************************************/
5941 /* Chapter 3: Declarations and Types */
5942 /**************************************/
5944 case N_Subtype_Declaration:
5945 case N_Full_Type_Declaration:
5946 case N_Incomplete_Type_Declaration:
5947 case N_Private_Type_Declaration:
5948 case N_Private_Extension_Declaration:
5949 case N_Task_Type_Declaration:
5950 process_type (Defining_Entity (gnat_node));
5951 gnu_result = alloc_stmt_list ();
5952 break;
5954 case N_Object_Declaration:
5955 case N_Exception_Declaration:
5956 gnat_temp = Defining_Entity (gnat_node);
5957 gnu_result = alloc_stmt_list ();
5959 /* If we are just annotating types and this object has an unconstrained
5960 or task type, don't elaborate it. */
5961 if (type_annotate_only
5962 && (((Is_Array_Type (Etype (gnat_temp))
5963 || Is_Record_Type (Etype (gnat_temp)))
5964 && !Is_Constrained (Etype (gnat_temp)))
5965 || Is_Concurrent_Type (Etype (gnat_temp))))
5966 break;
5968 if (Present (Expression (gnat_node))
5969 && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
5970 && (!type_annotate_only
5971 || Compile_Time_Known_Value (Expression (gnat_node))))
5973 gnu_expr = gnat_to_gnu (Expression (gnat_node));
5974 if (Do_Range_Check (Expression (gnat_node)))
5975 gnu_expr
5976 = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
5978 if (type_annotate_only && TREE_CODE (gnu_expr) == ERROR_MARK)
5979 gnu_expr = NULL_TREE;
5981 else
5982 gnu_expr = NULL_TREE;
5984 /* If this is a deferred constant with an address clause, we ignore the
5985 full view since the clause is on the partial view and we cannot have
5986 2 different GCC trees for the object. The only bits of the full view
5987 we will use is the initializer, but it will be directly fetched. */
5988 if (Ekind(gnat_temp) == E_Constant
5989 && Present (Address_Clause (gnat_temp))
5990 && Present (Full_View (gnat_temp)))
5991 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
5993 /* If this object has its elaboration delayed, we must force evaluation
5994 of GNU_EXPR now and save it for the freeze point. Note that we need
5995 not do anything special at the global level since the lifetime of the
5996 temporary is fully contained within the elaboration routine. */
5997 if (Present (Freeze_Node (gnat_temp)))
5999 if (gnu_expr)
6001 gnu_result = gnat_save_expr (gnu_expr);
6002 save_gnu_tree (gnat_node, gnu_result, true);
6005 else
6006 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
6007 break;
6009 case N_Object_Renaming_Declaration:
6010 gnat_temp = Defining_Entity (gnat_node);
6011 gnu_result = alloc_stmt_list ();
6013 /* Don't do anything if this renaming is handled by the front end or if
6014 we are just annotating types and this object has a composite or task
6015 type, don't elaborate it. */
6016 if (!Is_Renaming_Of_Object (gnat_temp)
6017 && ! (type_annotate_only
6018 && (Is_Array_Type (Etype (gnat_temp))
6019 || Is_Record_Type (Etype (gnat_temp))
6020 || Is_Concurrent_Type (Etype (gnat_temp)))))
6022 tree gnu_temp
6023 = gnat_to_gnu_entity (gnat_temp,
6024 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
6025 /* See case 2 of renaming in gnat_to_gnu_entity. */
6026 if (TREE_SIDE_EFFECTS (gnu_temp))
6027 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
6029 break;
6031 case N_Exception_Renaming_Declaration:
6032 gnat_temp = Defining_Entity (gnat_node);
6033 gnu_result = alloc_stmt_list ();
6035 /* See the above case for the rationale. */
6036 if (Present (Renamed_Entity (gnat_temp)))
6038 tree gnu_temp
6039 = gnat_to_gnu_entity (gnat_temp,
6040 gnat_to_gnu (Renamed_Entity (gnat_temp)), 1);
6041 if (TREE_SIDE_EFFECTS (gnu_temp))
6042 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
6044 break;
6046 case N_Subprogram_Renaming_Declaration:
6048 const Node_Id gnat_renaming = Defining_Entity (gnat_node);
6049 const Node_Id gnat_renamed = Renamed_Entity (gnat_renaming);
6051 gnu_result = alloc_stmt_list ();
6053 /* Materializing renamed subprograms will only benefit the debugging
6054 information as they aren't referenced in the generated code. So
6055 skip them when they aren't needed. Avoid doing this if:
6057 - there is a freeze node: in this case the renamed entity is not
6058 elaborated yet,
6059 - the renamed subprogram is intrinsic: it will not be available in
6060 the debugging information (note that both or only one of the
6061 renaming and the renamed subprograms can be intrinsic). */
6062 if (!type_annotate_only
6063 && Needs_Debug_Info (gnat_renaming)
6064 && No (Freeze_Node (gnat_renaming))
6065 && Present (gnat_renamed)
6066 && (Ekind (gnat_renamed) == E_Function
6067 || Ekind (gnat_renamed) == E_Procedure)
6068 && !Is_Intrinsic_Subprogram (gnat_renaming)
6069 && !Is_Intrinsic_Subprogram (gnat_renamed))
6070 gnat_to_gnu_entity (gnat_renaming, gnat_to_gnu (gnat_renamed), 1);
6071 break;
6074 case N_Implicit_Label_Declaration:
6075 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
6076 gnu_result = alloc_stmt_list ();
6077 break;
6079 case N_Number_Declaration:
6080 case N_Package_Renaming_Declaration:
6081 /* These are fully handled in the front end. */
6082 /* ??? For package renamings, find a way to use GENERIC namespaces so
6083 that we get proper debug information for them. */
6084 gnu_result = alloc_stmt_list ();
6085 break;
6087 /*************************************/
6088 /* Chapter 4: Names and Expressions */
6089 /*************************************/
6091 case N_Explicit_Dereference:
6092 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6093 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6094 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
6096 /* If atomic access is required on the RHS, build the atomic load. */
6097 if (atomic_access_required_p (gnat_node, &sync)
6098 && !present_in_lhs_or_actual_p (gnat_node))
6099 gnu_result = build_atomic_load (gnu_result, sync);
6100 break;
6102 case N_Indexed_Component:
6104 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
6105 tree gnu_type;
6106 int ndim;
6107 int i;
6108 Node_Id *gnat_expr_array;
6110 gnu_array_object = maybe_implicit_deref (gnu_array_object);
6112 /* Convert vector inputs to their representative array type, to fit
6113 what the code below expects. */
6114 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object)))
6116 if (present_in_lhs_or_actual_p (gnat_node))
6117 gnat_mark_addressable (gnu_array_object);
6118 gnu_array_object = maybe_vector_array (gnu_array_object);
6121 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6123 /* If we got a padded type, remove it too. */
6124 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
6125 gnu_array_object
6126 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
6127 gnu_array_object);
6129 gnu_result = gnu_array_object;
6131 /* The failure of this assertion will very likely come from a missing
6132 expansion for a packed array access. */
6133 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
6135 /* First compute the number of dimensions of the array, then
6136 fill the expression array, the order depending on whether
6137 this is a Convention_Fortran array or not. */
6138 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
6139 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6140 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
6141 ndim++, gnu_type = TREE_TYPE (gnu_type))
6144 gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
6146 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
6147 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
6148 i >= 0;
6149 i--, gnat_temp = Next (gnat_temp))
6150 gnat_expr_array[i] = gnat_temp;
6151 else
6152 for (i = 0, gnat_temp = First (Expressions (gnat_node));
6153 i < ndim;
6154 i++, gnat_temp = Next (gnat_temp))
6155 gnat_expr_array[i] = gnat_temp;
6157 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
6158 i < ndim;
6159 i++, gnu_type = TREE_TYPE (gnu_type))
6161 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
6162 gnat_temp = gnat_expr_array[i];
6163 gnu_expr = gnat_to_gnu (gnat_temp);
6164 struct loop_info_d *loop;
6166 if (Do_Range_Check (gnat_temp))
6167 gnu_expr
6168 = emit_index_check
6169 (gnu_array_object, gnu_expr,
6170 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
6171 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
6172 gnat_temp);
6174 gnu_result
6175 = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
6177 /* Array accesses are bound-checked so they cannot trap, but this
6178 is valid only if they are not hoisted ahead of the check. We
6179 need to mark them as no-trap to get decent loop optimizations
6180 in the presence of -fnon-call-exceptions, so we do it when we
6181 know that the original expression had no side-effects. */
6182 if (TREE_CODE (gnu_result) == ARRAY_REF
6183 && !(Nkind (gnat_temp) == N_Identifier
6184 && Ekind (Entity (gnat_temp)) == E_Constant))
6185 TREE_THIS_NOTRAP (gnu_result) = 1;
6187 /* If aggressive loop optimizations are enabled, we warn for loops
6188 overrunning a simple array of size 1 not at the end of a record.
6189 This is aimed to catch misuses of the trailing array idiom. */
6190 if (optimize
6191 && flag_aggressive_loop_optimizations
6192 && inside_loop_p ()
6193 && TREE_CODE (TREE_TYPE (gnu_type)) != ARRAY_TYPE
6194 && TREE_CODE (gnu_array_object) != ARRAY_REF
6195 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_type)),
6196 TYPE_MAX_VALUE (TYPE_DOMAIN (gnu_type)))
6197 && !array_at_struct_end_p (gnu_result)
6198 && (loop = find_loop_for (skip_simple_arithmetic (gnu_expr)))
6199 && !loop->artificial
6200 && !loop->has_checks
6201 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_type)),
6202 loop->low_bound)
6203 && can_be_lower_p (loop->low_bound, loop->high_bound)
6204 && !loop->warned_aggressive_loop_optimizations
6205 && warning (OPT_Waggressive_loop_optimizations,
6206 "out-of-bounds access may be optimized away"))
6208 inform (EXPR_LOCATION (loop->stmt), "containing loop");
6209 loop->warned_aggressive_loop_optimizations = true;
6213 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6215 /* If atomic access is required on the RHS, build the atomic load. */
6216 if (atomic_access_required_p (gnat_node, &sync)
6217 && !present_in_lhs_or_actual_p (gnat_node))
6218 gnu_result = build_atomic_load (gnu_result, sync);
6220 break;
6222 case N_Slice:
6224 Node_Id gnat_range_node = Discrete_Range (gnat_node);
6225 tree gnu_type;
6227 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6228 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6230 /* Do any implicit dereferences of the prefix and do any needed
6231 range check. */
6232 gnu_result = maybe_implicit_deref (gnu_result);
6233 gnu_result = maybe_unconstrained_array (gnu_result);
6234 gnu_type = TREE_TYPE (gnu_result);
6235 if (Do_Range_Check (gnat_range_node))
6237 /* Get the bounds of the slice. */
6238 tree gnu_index_type
6239 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
6240 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
6241 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
6242 /* Get the permitted bounds. */
6243 tree gnu_base_index_type
6244 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
6245 tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
6246 (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
6247 tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
6248 (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
6249 tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
6251 gnu_min_expr = gnat_protect_expr (gnu_min_expr);
6252 gnu_max_expr = gnat_protect_expr (gnu_max_expr);
6254 /* Derive a good type to convert everything to. */
6255 gnu_expr_type = get_base_type (gnu_index_type);
6257 /* Test whether the minimum slice value is too small. */
6258 gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
6259 convert (gnu_expr_type,
6260 gnu_min_expr),
6261 convert (gnu_expr_type,
6262 gnu_base_min_expr));
6264 /* Test whether the maximum slice value is too large. */
6265 gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
6266 convert (gnu_expr_type,
6267 gnu_max_expr),
6268 convert (gnu_expr_type,
6269 gnu_base_max_expr));
6271 /* Build a slice index check that returns the low bound,
6272 assuming the slice is not empty. */
6273 gnu_expr = emit_check
6274 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
6275 gnu_expr_l, gnu_expr_h),
6276 gnu_min_expr, CE_Index_Check_Failed, gnat_node);
6278 /* Build a conditional expression that does the index checks and
6279 returns the low bound if the slice is not empty (max >= min),
6280 and returns the naked low bound otherwise (max < min), unless
6281 it is non-constant and the high bound is; this prevents VRP
6282 from inferring bogus ranges on the unlikely path. */
6283 gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
6284 build_binary_op (GE_EXPR, gnu_expr_type,
6285 convert (gnu_expr_type,
6286 gnu_max_expr),
6287 convert (gnu_expr_type,
6288 gnu_min_expr)),
6289 gnu_expr,
6290 TREE_CODE (gnu_min_expr) != INTEGER_CST
6291 && TREE_CODE (gnu_max_expr) == INTEGER_CST
6292 ? gnu_max_expr : gnu_min_expr);
6294 else
6295 /* Simply return the naked low bound. */
6296 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6298 /* If this is a slice with non-constant size of an array with constant
6299 size, set the maximum size for the allocation of temporaries. */
6300 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
6301 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
6302 TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
6304 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
6305 gnu_result, gnu_expr);
6307 break;
6309 case N_Selected_Component:
6311 Entity_Id gnat_prefix = Prefix (gnat_node);
6312 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
6313 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
6314 tree gnu_field;
6316 gnu_prefix = maybe_implicit_deref (gnu_prefix);
6318 /* For discriminant references in tagged types always substitute the
6319 corresponding discriminant as the actual selected component. */
6320 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix))))
6321 while (Present (Corresponding_Discriminant (gnat_field)))
6322 gnat_field = Corresponding_Discriminant (gnat_field);
6324 /* For discriminant references of untagged types always substitute the
6325 corresponding stored discriminant. */
6326 else if (Present (Corresponding_Discriminant (gnat_field)))
6327 gnat_field = Original_Record_Component (gnat_field);
6329 /* Handle extracting the real or imaginary part of a complex.
6330 The real part is the first field and the imaginary the last. */
6331 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
6332 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
6333 ? REALPART_EXPR : IMAGPART_EXPR,
6334 NULL_TREE, gnu_prefix);
6335 else
6337 gnu_field = gnat_to_gnu_field_decl (gnat_field);
6339 gnu_result
6340 = build_component_ref (gnu_prefix, gnu_field,
6341 (Nkind (Parent (gnat_node))
6342 == N_Attribute_Reference)
6343 && lvalue_required_for_attribute_p
6344 (Parent (gnat_node)));
6347 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6349 /* If atomic access is required on the RHS, build the atomic load. */
6350 if (atomic_access_required_p (gnat_node, &sync)
6351 && !present_in_lhs_or_actual_p (gnat_node))
6352 gnu_result = build_atomic_load (gnu_result, sync);
6354 break;
6356 case N_Attribute_Reference:
6358 /* The attribute designator. */
6359 const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
6361 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6362 is a unit, not an object with a GCC equivalent. */
6363 if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
6364 return
6365 create_subprog_decl (create_concat_name
6366 (Entity (Prefix (gnat_node)),
6367 attr == Attr_Elab_Body ? "elabb" : "elabs"),
6368 NULL_TREE, void_ftype, NULL_TREE, is_disabled,
6369 true, true, true, true, NULL, gnat_node);
6371 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
6373 break;
6375 case N_Reference:
6376 /* Like 'Access as far as we are concerned. */
6377 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6378 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6379 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6380 break;
6382 case N_Aggregate:
6383 case N_Extension_Aggregate:
6385 tree gnu_aggr_type;
6387 /* ??? It is wrong to evaluate the type now, but there doesn't
6388 seem to be any other practical way of doing it. */
6390 gcc_assert (!Expansion_Delayed (gnat_node));
6392 gnu_aggr_type = gnu_result_type
6393 = get_unpadded_type (Etype (gnat_node));
6395 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
6396 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
6397 gnu_aggr_type
6398 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type)));
6399 else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
6400 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
6402 if (Null_Record_Present (gnat_node))
6403 gnu_result = gnat_build_constructor (gnu_aggr_type,
6404 NULL);
6406 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
6407 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
6408 gnu_result
6409 = assoc_to_constructor (Etype (gnat_node),
6410 First (Component_Associations (gnat_node)),
6411 gnu_aggr_type);
6412 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
6413 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
6414 gnu_aggr_type,
6415 Component_Type (Etype (gnat_node)));
6416 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
6417 gnu_result
6418 = build_binary_op
6419 (COMPLEX_EXPR, gnu_aggr_type,
6420 gnat_to_gnu (Expression (First
6421 (Component_Associations (gnat_node)))),
6422 gnat_to_gnu (Expression
6423 (Next
6424 (First (Component_Associations (gnat_node))))));
6425 else
6426 gcc_unreachable ();
6428 gnu_result = convert (gnu_result_type, gnu_result);
6430 break;
6432 case N_Null:
6433 if (TARGET_VTABLE_USES_DESCRIPTORS
6434 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
6435 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
6436 gnu_result = null_fdesc_node;
6437 else
6438 gnu_result = null_pointer_node;
6439 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6440 break;
6442 case N_Type_Conversion:
6443 case N_Qualified_Expression:
6444 /* Get the operand expression. */
6445 gnu_result = gnat_to_gnu (Expression (gnat_node));
6446 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6448 /* If this is a qualified expression for a tagged type, we mark the type
6449 as used. Because of polymorphism, this might be the only reference to
6450 the tagged type in the program while objects have it as dynamic type.
6451 The debugger needs to see it to display these objects properly. */
6452 if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
6453 used_types_insert (gnu_result_type);
6455 gnu_result
6456 = convert_with_check (Etype (gnat_node), gnu_result,
6457 Do_Overflow_Check (gnat_node),
6458 Do_Range_Check (Expression (gnat_node)),
6459 kind == N_Type_Conversion
6460 && Float_Truncate (gnat_node), gnat_node);
6461 break;
6463 case N_Unchecked_Type_Conversion:
6464 gnu_result = gnat_to_gnu (Expression (gnat_node));
6466 /* Skip further processing if the conversion is deemed a no-op. */
6467 if (unchecked_conversion_nop (gnat_node))
6469 gnu_result_type = TREE_TYPE (gnu_result);
6470 break;
6473 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6475 /* If the result is a pointer type, see if we are improperly
6476 converting to a stricter alignment. */
6477 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
6478 && IN (Ekind (Etype (gnat_node)), Access_Kind))
6480 unsigned int align = known_alignment (gnu_result);
6481 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
6482 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
6484 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
6485 post_error_ne_tree_2
6486 ("?source alignment (^) '< alignment of & (^)",
6487 gnat_node, Designated_Type (Etype (gnat_node)),
6488 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
6491 /* If we are converting a descriptor to a function pointer, first
6492 build the pointer. */
6493 if (TARGET_VTABLE_USES_DESCRIPTORS
6494 && TREE_TYPE (gnu_result) == fdesc_type_node
6495 && POINTER_TYPE_P (gnu_result_type))
6496 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6498 gnu_result = unchecked_convert (gnu_result_type, gnu_result,
6499 No_Truncation (gnat_node));
6500 break;
6502 case N_In:
6503 case N_Not_In:
6505 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
6506 Node_Id gnat_range = Right_Opnd (gnat_node);
6507 tree gnu_low, gnu_high;
6509 /* GNAT_RANGE is either an N_Range node or an identifier denoting a
6510 subtype. */
6511 if (Nkind (gnat_range) == N_Range)
6513 gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
6514 gnu_high = gnat_to_gnu (High_Bound (gnat_range));
6516 else if (Nkind (gnat_range) == N_Identifier
6517 || Nkind (gnat_range) == N_Expanded_Name)
6519 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
6520 tree gnu_range_base_type = get_base_type (gnu_range_type);
6522 gnu_low
6523 = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
6524 gnu_high
6525 = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
6527 else
6528 gcc_unreachable ();
6530 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6532 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
6533 ensure that GNU_OBJ is evaluated only once and perform a full range
6534 test. */
6535 if (operand_equal_p (gnu_low, gnu_high, 0))
6536 gnu_result
6537 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
6538 else
6540 tree t1, t2;
6541 gnu_obj = gnat_protect_expr (gnu_obj);
6542 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
6543 if (EXPR_P (t1))
6544 set_expr_location_from_node (t1, gnat_node);
6545 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
6546 if (EXPR_P (t2))
6547 set_expr_location_from_node (t2, gnat_node);
6548 gnu_result
6549 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
6552 if (kind == N_Not_In)
6553 gnu_result
6554 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
6556 break;
6558 case N_Op_Divide:
6559 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6560 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6561 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6562 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
6563 ? RDIV_EXPR
6564 : (Rounded_Result (gnat_node)
6565 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
6566 gnu_result_type, gnu_lhs, gnu_rhs);
6567 break;
6569 case N_Op_Or: case N_Op_And: case N_Op_Xor:
6570 /* These can either be operations on booleans or on modular types.
6571 Fall through for boolean types since that's the way GNU_CODES is
6572 set up. */
6573 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6575 enum tree_code code
6576 = (kind == N_Op_Or ? BIT_IOR_EXPR
6577 : kind == N_Op_And ? BIT_AND_EXPR
6578 : BIT_XOR_EXPR);
6580 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6581 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6582 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6583 gnu_result = build_binary_op (code, gnu_result_type,
6584 gnu_lhs, gnu_rhs);
6585 break;
6588 /* ... fall through ... */
6590 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
6591 case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
6592 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
6593 case N_Op_Mod: case N_Op_Rem:
6594 case N_Op_Rotate_Left:
6595 case N_Op_Rotate_Right:
6596 case N_Op_Shift_Left:
6597 case N_Op_Shift_Right:
6598 case N_Op_Shift_Right_Arithmetic:
6599 case N_And_Then: case N_Or_Else:
6601 enum tree_code code = gnu_codes[kind];
6602 bool ignore_lhs_overflow = false;
6603 location_t saved_location = input_location;
6604 tree gnu_type;
6606 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6607 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6608 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
6610 /* Pending generic support for efficient vector logical operations in
6611 GCC, convert vectors to their representative array type view and
6612 fallthrough. */
6613 gnu_lhs = maybe_vector_array (gnu_lhs);
6614 gnu_rhs = maybe_vector_array (gnu_rhs);
6616 /* If this is a comparison operator, convert any references to an
6617 unconstrained array value into a reference to the actual array. */
6618 if (TREE_CODE_CLASS (code) == tcc_comparison)
6620 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
6621 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
6624 /* If this is a shift whose count is not guaranteed to be correct,
6625 we need to adjust the shift count. */
6626 if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
6628 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
6629 tree gnu_max_shift
6630 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
6632 if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
6633 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
6634 gnu_rhs, gnu_max_shift);
6635 else if (kind == N_Op_Shift_Right_Arithmetic)
6636 gnu_rhs
6637 = build_binary_op
6638 (MIN_EXPR, gnu_count_type,
6639 build_binary_op (MINUS_EXPR,
6640 gnu_count_type,
6641 gnu_max_shift,
6642 convert (gnu_count_type,
6643 integer_one_node)),
6644 gnu_rhs);
6647 /* For right shifts, the type says what kind of shift to do,
6648 so we may need to choose a different type. In this case,
6649 we have to ignore integer overflow lest it propagates all
6650 the way down and causes a CE to be explicitly raised. */
6651 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
6653 gnu_type = gnat_unsigned_type (gnu_type);
6654 ignore_lhs_overflow = true;
6656 else if (kind == N_Op_Shift_Right_Arithmetic
6657 && TYPE_UNSIGNED (gnu_type))
6659 gnu_type = gnat_signed_type (gnu_type);
6660 ignore_lhs_overflow = true;
6663 if (gnu_type != gnu_result_type)
6665 tree gnu_old_lhs = gnu_lhs;
6666 gnu_lhs = convert (gnu_type, gnu_lhs);
6667 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
6668 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
6669 gnu_rhs = convert (gnu_type, gnu_rhs);
6672 /* Instead of expanding overflow checks for addition, subtraction
6673 and multiplication itself, the front end will leave this to
6674 the back end when Backend_Overflow_Checks_On_Target is set.
6675 As the GCC back end itself does not know yet how to properly
6676 do overflow checking, do it here. The goal is to push
6677 the expansions further into the back end over time. */
6678 if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
6679 && (kind == N_Op_Add
6680 || kind == N_Op_Subtract
6681 || kind == N_Op_Multiply)
6682 && !TYPE_UNSIGNED (gnu_type)
6683 && !FLOAT_TYPE_P (gnu_type))
6684 gnu_result = build_binary_op_trapv (code, gnu_type,
6685 gnu_lhs, gnu_rhs, gnat_node);
6686 else
6688 /* Some operations, e.g. comparisons of arrays, generate complex
6689 trees that need to be annotated while they are being built. */
6690 input_location = saved_location;
6691 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
6694 /* If this is a logical shift with the shift count not verified,
6695 we must return zero if it is too large. We cannot compensate
6696 above in this case. */
6697 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
6698 && !Shift_Count_OK (gnat_node))
6699 gnu_result
6700 = build_cond_expr
6701 (gnu_type,
6702 build_binary_op (GE_EXPR, boolean_type_node,
6703 gnu_rhs,
6704 convert (TREE_TYPE (gnu_rhs),
6705 TYPE_SIZE (gnu_type))),
6706 convert (gnu_type, integer_zero_node),
6707 gnu_result);
6709 break;
6711 case N_If_Expression:
6713 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
6714 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
6715 tree gnu_false
6716 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
6718 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6719 gnu_result
6720 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
6722 break;
6724 case N_Op_Plus:
6725 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
6726 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6727 break;
6729 case N_Op_Not:
6730 /* This case can apply to a boolean or a modular type.
6731 Fall through for a boolean operand since GNU_CODES is set
6732 up to handle this. */
6733 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6735 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
6736 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6737 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
6738 gnu_expr);
6739 break;
6742 /* ... fall through ... */
6744 case N_Op_Minus: case N_Op_Abs:
6745 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
6746 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6748 if (Do_Overflow_Check (gnat_node)
6749 && !TYPE_UNSIGNED (gnu_result_type)
6750 && !FLOAT_TYPE_P (gnu_result_type))
6751 gnu_result
6752 = build_unary_op_trapv (gnu_codes[kind],
6753 gnu_result_type, gnu_expr, gnat_node);
6754 else
6755 gnu_result = build_unary_op (gnu_codes[kind],
6756 gnu_result_type, gnu_expr);
6757 break;
6759 case N_Allocator:
6761 tree gnu_init = 0;
6762 tree gnu_type;
6763 bool ignore_init_type = false;
6765 gnat_temp = Expression (gnat_node);
6767 /* The Expression operand can either be an N_Identifier or
6768 Expanded_Name, which must represent a type, or a
6769 N_Qualified_Expression, which contains both the object type and an
6770 initial value for the object. */
6771 if (Nkind (gnat_temp) == N_Identifier
6772 || Nkind (gnat_temp) == N_Expanded_Name)
6773 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
6774 else if (Nkind (gnat_temp) == N_Qualified_Expression)
6776 Entity_Id gnat_desig_type
6777 = Designated_Type (Underlying_Type (Etype (gnat_node)));
6779 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
6780 gnu_init = gnat_to_gnu (Expression (gnat_temp));
6782 gnu_init = maybe_unconstrained_array (gnu_init);
6783 if (Do_Range_Check (Expression (gnat_temp)))
6784 gnu_init
6785 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
6787 if (Is_Elementary_Type (gnat_desig_type)
6788 || Is_Constrained (gnat_desig_type))
6789 gnu_type = gnat_to_gnu_type (gnat_desig_type);
6790 else
6792 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
6793 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
6794 gnu_type = TREE_TYPE (gnu_init);
6797 /* See the N_Qualified_Expression case for the rationale. */
6798 if (Is_Tagged_Type (gnat_desig_type))
6799 used_types_insert (gnu_type);
6801 gnu_init = convert (gnu_type, gnu_init);
6803 else
6804 gcc_unreachable ();
6806 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6807 return build_allocator (gnu_type, gnu_init, gnu_result_type,
6808 Procedure_To_Call (gnat_node),
6809 Storage_Pool (gnat_node), gnat_node,
6810 ignore_init_type);
6812 break;
6814 /**************************/
6815 /* Chapter 5: Statements */
6816 /**************************/
6818 case N_Label:
6819 gnu_result = build1 (LABEL_EXPR, void_type_node,
6820 gnat_to_gnu (Identifier (gnat_node)));
6821 break;
6823 case N_Null_Statement:
6824 /* When not optimizing, turn null statements from source into gotos to
6825 the next statement that the middle-end knows how to preserve. */
6826 if (!optimize && Comes_From_Source (gnat_node))
6828 tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
6829 DECL_IGNORED_P (label) = 1;
6830 start_stmt_group ();
6831 stmt = build1 (GOTO_EXPR, void_type_node, label);
6832 set_expr_location_from_node (stmt, gnat_node);
6833 add_stmt (stmt);
6834 stmt = build1 (LABEL_EXPR, void_type_node, label);
6835 set_expr_location_from_node (stmt, gnat_node);
6836 add_stmt (stmt);
6837 gnu_result = end_stmt_group ();
6839 else
6840 gnu_result = alloc_stmt_list ();
6841 break;
6843 case N_Assignment_Statement:
6844 /* Get the LHS and RHS of the statement and convert any reference to an
6845 unconstrained array into a reference to the underlying array. */
6846 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
6848 /* If the type has a size that overflows, convert this into raise of
6849 Storage_Error: execution shouldn't have gotten here anyway. */
6850 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
6851 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
6852 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
6853 N_Raise_Storage_Error);
6854 else if (Nkind (Expression (gnat_node)) == N_Function_Call)
6856 bool outer_atomic_access
6857 = outer_atomic_access_required_p (Name (gnat_node));
6858 bool atomic_access
6859 = !outer_atomic_access
6860 && atomic_access_required_p (Name (gnat_node), &sync);
6861 gnu_result
6862 = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
6863 outer_atomic_access, atomic_access, sync);
6865 else
6867 const Node_Id gnat_expr = Expression (gnat_node);
6868 const Entity_Id gnat_type
6869 = Underlying_Type (Etype (Name (gnat_node)));
6870 const bool regular_array_type_p
6871 = (Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type));
6872 const bool use_memset_p
6873 = (regular_array_type_p
6874 && Nkind (gnat_expr) == N_Aggregate
6875 && Is_Others_Aggregate (gnat_expr));
6877 /* If we'll use memset, we need to find the inner expression. */
6878 if (use_memset_p)
6880 Node_Id gnat_inner
6881 = Expression (First (Component_Associations (gnat_expr)));
6882 while (Nkind (gnat_inner) == N_Aggregate
6883 && Is_Others_Aggregate (gnat_inner))
6884 gnat_inner
6885 = Expression (First (Component_Associations (gnat_inner)));
6886 gnu_rhs = gnat_to_gnu (gnat_inner);
6888 else
6889 gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
6891 /* If range check is needed, emit code to generate it. */
6892 if (Do_Range_Check (gnat_expr))
6893 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
6894 gnat_node);
6896 /* If an outer atomic access is required on the LHS, build the load-
6897 modify-store sequence. */
6898 if (outer_atomic_access_required_p (Name (gnat_node)))
6899 gnu_result = build_load_modify_store (gnu_lhs, gnu_rhs, gnat_node);
6901 /* Or else, if atomic access is required, build the atomic store. */
6902 else if (atomic_access_required_p (Name (gnat_node), &sync))
6903 gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, sync);
6905 /* Or else, use memset when the conditions are met. */
6906 else if (use_memset_p)
6908 tree value = fold_convert (integer_type_node, gnu_rhs);
6909 tree to = gnu_lhs;
6910 tree type = TREE_TYPE (to);
6911 tree size
6912 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), to);
6913 tree to_ptr = build_fold_addr_expr (to);
6914 tree t = builtin_decl_explicit (BUILT_IN_MEMSET);
6915 if (TREE_CODE (value) == INTEGER_CST)
6917 tree mask
6918 = build_int_cst (integer_type_node,
6919 ((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1);
6920 value = int_const_binop (BIT_AND_EXPR, value, mask);
6922 gnu_result = build_call_expr (t, 3, to_ptr, value, size);
6925 /* Otherwise build a regular assignment. */
6926 else
6927 gnu_result
6928 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
6930 /* If the assignment type is a regular array and the two sides are
6931 not completely disjoint, play safe and use memmove. But don't do
6932 it for a bit-packed array as it might not be byte-aligned. */
6933 if (TREE_CODE (gnu_result) == MODIFY_EXPR
6934 && regular_array_type_p
6935 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
6937 tree to = TREE_OPERAND (gnu_result, 0);
6938 tree from = TREE_OPERAND (gnu_result, 1);
6939 tree type = TREE_TYPE (from);
6940 tree size
6941 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from);
6942 tree to_ptr = build_fold_addr_expr (to);
6943 tree from_ptr = build_fold_addr_expr (from);
6944 tree t = builtin_decl_explicit (BUILT_IN_MEMMOVE);
6945 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
6948 break;
6950 case N_If_Statement:
6952 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
6954 /* Make the outer COND_EXPR. Avoid non-determinism. */
6955 gnu_result = build3 (COND_EXPR, void_type_node,
6956 gnat_to_gnu (Condition (gnat_node)),
6957 NULL_TREE, NULL_TREE);
6958 COND_EXPR_THEN (gnu_result)
6959 = build_stmt_group (Then_Statements (gnat_node), false);
6960 TREE_SIDE_EFFECTS (gnu_result) = 1;
6961 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
6963 /* Now make a COND_EXPR for each of the "else if" parts. Put each
6964 into the previous "else" part and point to where to put any
6965 outer "else". Also avoid non-determinism. */
6966 if (Present (Elsif_Parts (gnat_node)))
6967 for (gnat_temp = First (Elsif_Parts (gnat_node));
6968 Present (gnat_temp); gnat_temp = Next (gnat_temp))
6970 gnu_expr = build3 (COND_EXPR, void_type_node,
6971 gnat_to_gnu (Condition (gnat_temp)),
6972 NULL_TREE, NULL_TREE);
6973 COND_EXPR_THEN (gnu_expr)
6974 = build_stmt_group (Then_Statements (gnat_temp), false);
6975 TREE_SIDE_EFFECTS (gnu_expr) = 1;
6976 set_expr_location_from_node (gnu_expr, gnat_temp);
6977 *gnu_else_ptr = gnu_expr;
6978 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
6981 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
6983 break;
6985 case N_Case_Statement:
6986 gnu_result = Case_Statement_to_gnu (gnat_node);
6987 break;
6989 case N_Loop_Statement:
6990 gnu_result = Loop_Statement_to_gnu (gnat_node);
6991 break;
6993 case N_Block_Statement:
6994 /* The only way to enter the block is to fall through to it. */
6995 if (stmt_group_may_fallthru ())
6997 start_stmt_group ();
6998 gnat_pushlevel ();
6999 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7000 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7001 gnat_poplevel ();
7002 gnu_result = end_stmt_group ();
7004 else
7005 gnu_result = alloc_stmt_list ();
7006 break;
7008 case N_Exit_Statement:
7009 gnu_result
7010 = build2 (EXIT_STMT, void_type_node,
7011 (Present (Condition (gnat_node))
7012 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
7013 (Present (Name (gnat_node))
7014 ? get_gnu_tree (Entity (Name (gnat_node)))
7015 : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt)));
7016 break;
7018 case N_Simple_Return_Statement:
7020 tree gnu_ret_obj, gnu_ret_val;
7022 /* If the subprogram is a function, we must return the expression. */
7023 if (Present (Expression (gnat_node)))
7025 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
7027 /* If this function has copy-in/copy-out parameters parameters and
7028 doesn't return by invisible reference, get the real object for
7029 the return. See Subprogram_Body_to_gnu. */
7030 if (TYPE_CI_CO_LIST (gnu_subprog_type)
7031 && !TREE_ADDRESSABLE (gnu_subprog_type))
7032 gnu_ret_obj = gnu_return_var_stack->last ();
7033 else
7034 gnu_ret_obj = DECL_RESULT (current_function_decl);
7036 /* Get the GCC tree for the expression to be returned. */
7037 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
7039 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7040 self-referential since we want to allocate the fixed size. */
7041 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
7042 && type_is_padding_self_referential
7043 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
7044 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
7046 /* If the function returns by direct reference, return a pointer
7047 to the return value. */
7048 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
7049 || By_Ref (gnat_node))
7050 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
7052 /* Otherwise, if it returns an unconstrained array, we have to
7053 allocate a new version of the result and return it. */
7054 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
7056 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
7058 /* And find out whether this is a candidate for Named Return
7059 Value. If so, record it. */
7060 if (!TYPE_CI_CO_LIST (gnu_subprog_type) && optimize)
7062 tree ret_val = gnu_ret_val;
7064 /* Strip useless conversions around the return value. */
7065 if (gnat_useless_type_conversion (ret_val))
7066 ret_val = TREE_OPERAND (ret_val, 0);
7068 /* Strip unpadding around the return value. */
7069 if (TREE_CODE (ret_val) == COMPONENT_REF
7070 && TYPE_IS_PADDING_P
7071 (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
7072 ret_val = TREE_OPERAND (ret_val, 0);
7074 /* Now apply the test to the return value. */
7075 if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
7077 if (!f_named_ret_val)
7078 f_named_ret_val = BITMAP_GGC_ALLOC ();
7079 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
7080 if (!f_gnat_ret)
7081 f_gnat_ret = gnat_node;
7085 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
7086 gnu_ret_val,
7087 TREE_TYPE (gnu_ret_obj),
7088 Procedure_To_Call (gnat_node),
7089 Storage_Pool (gnat_node),
7090 gnat_node, false);
7093 /* Otherwise, if it returns by invisible reference, dereference
7094 the pointer it is passed using the type of the return value
7095 and build the copy operation manually. This ensures that we
7096 don't copy too much data, for example if the return type is
7097 unconstrained with a maximum size. */
7098 else if (TREE_ADDRESSABLE (gnu_subprog_type))
7100 tree gnu_ret_deref
7101 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
7102 gnu_ret_obj);
7103 gnu_result = build2 (INIT_EXPR, void_type_node,
7104 gnu_ret_deref, gnu_ret_val);
7105 add_stmt_with_node (gnu_result, gnat_node);
7106 gnu_ret_val = NULL_TREE;
7110 else
7111 gnu_ret_obj = gnu_ret_val = NULL_TREE;
7113 /* If we have a return label defined, convert this into a branch to
7114 that label. The return proper will be handled elsewhere. */
7115 if (gnu_return_label_stack->last ())
7117 if (gnu_ret_val)
7118 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
7119 gnu_ret_val));
7121 gnu_result = build1 (GOTO_EXPR, void_type_node,
7122 gnu_return_label_stack->last ());
7124 /* When not optimizing, make sure the return is preserved. */
7125 if (!optimize && Comes_From_Source (gnat_node))
7126 DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0;
7129 /* Otherwise, build a regular return. */
7130 else
7131 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
7133 break;
7135 case N_Goto_Statement:
7136 gnu_result
7137 = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node)));
7138 break;
7140 /***************************/
7141 /* Chapter 6: Subprograms */
7142 /***************************/
7144 case N_Subprogram_Declaration:
7145 /* Unless there is a freeze node, declare the subprogram. We consider
7146 this a "definition" even though we're not generating code for
7147 the subprogram because we will be making the corresponding GCC
7148 node here. */
7150 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7151 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
7152 NULL_TREE, 1);
7153 gnu_result = alloc_stmt_list ();
7154 break;
7156 case N_Abstract_Subprogram_Declaration:
7157 /* This subprogram doesn't exist for code generation purposes, but we
7158 have to elaborate the types of any parameters and result, unless
7159 they are imported types (nothing to generate in this case).
7161 The parameter list may contain types with freeze nodes, e.g. not null
7162 subtypes, so the subprogram itself may carry a freeze node, in which
7163 case its elaboration must be deferred. */
7165 /* Process the parameter types first. */
7166 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7167 for (gnat_temp
7168 = First_Formal_With_Extras
7169 (Defining_Entity (Specification (gnat_node)));
7170 Present (gnat_temp);
7171 gnat_temp = Next_Formal_With_Extras (gnat_temp))
7172 if (Is_Itype (Etype (gnat_temp))
7173 && !From_Limited_With (Etype (gnat_temp)))
7174 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
7176 /* Then the result type, set to Standard_Void_Type for procedures. */
7178 Entity_Id gnat_temp_type
7179 = Etype (Defining_Entity (Specification (gnat_node)));
7181 if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type))
7182 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
7185 gnu_result = alloc_stmt_list ();
7186 break;
7188 case N_Defining_Program_Unit_Name:
7189 /* For a child unit identifier go up a level to get the specification.
7190 We get this when we try to find the spec of a child unit package
7191 that is the compilation unit being compiled. */
7192 gnu_result = gnat_to_gnu (Parent (gnat_node));
7193 break;
7195 case N_Subprogram_Body:
7196 Subprogram_Body_to_gnu (gnat_node);
7197 gnu_result = alloc_stmt_list ();
7198 break;
7200 case N_Function_Call:
7201 case N_Procedure_Call_Statement:
7202 gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
7203 false, false, false);
7204 break;
7206 /************************/
7207 /* Chapter 7: Packages */
7208 /************************/
7210 case N_Package_Declaration:
7211 gnu_result = gnat_to_gnu (Specification (gnat_node));
7212 break;
7214 case N_Package_Specification:
7216 start_stmt_group ();
7217 process_decls (Visible_Declarations (gnat_node),
7218 Private_Declarations (gnat_node), Empty, true, true);
7219 gnu_result = end_stmt_group ();
7220 break;
7222 case N_Package_Body:
7224 /* If this is the body of a generic package - do nothing. */
7225 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
7227 gnu_result = alloc_stmt_list ();
7228 break;
7231 start_stmt_group ();
7232 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7234 if (Present (Handled_Statement_Sequence (gnat_node)))
7235 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7237 gnu_result = end_stmt_group ();
7238 break;
7240 /********************************/
7241 /* Chapter 8: Visibility Rules */
7242 /********************************/
7244 case N_Use_Package_Clause:
7245 case N_Use_Type_Clause:
7246 /* Nothing to do here - but these may appear in list of declarations. */
7247 gnu_result = alloc_stmt_list ();
7248 break;
7250 /*********************/
7251 /* Chapter 9: Tasks */
7252 /*********************/
7254 case N_Protected_Type_Declaration:
7255 gnu_result = alloc_stmt_list ();
7256 break;
7258 case N_Single_Task_Declaration:
7259 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
7260 gnu_result = alloc_stmt_list ();
7261 break;
7263 /*********************************************************/
7264 /* Chapter 10: Program Structure and Compilation Issues */
7265 /*********************************************************/
7267 case N_Compilation_Unit:
7268 /* This is not called for the main unit on which gigi is invoked. */
7269 Compilation_Unit_to_gnu (gnat_node);
7270 gnu_result = alloc_stmt_list ();
7271 break;
7273 case N_Subprogram_Body_Stub:
7274 case N_Package_Body_Stub:
7275 case N_Protected_Body_Stub:
7276 case N_Task_Body_Stub:
7277 /* Simply process whatever unit is being inserted. */
7278 if (Present (Library_Unit (gnat_node)))
7279 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
7280 else
7282 gcc_assert (type_annotate_only);
7283 gnu_result = alloc_stmt_list ();
7285 break;
7287 case N_Subunit:
7288 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
7289 break;
7291 /***************************/
7292 /* Chapter 11: Exceptions */
7293 /***************************/
7295 case N_Handled_Sequence_Of_Statements:
7296 /* If there is an At_End procedure attached to this node, and the EH
7297 mechanism is SJLJ, we must have at least a corresponding At_End
7298 handler, unless the No_Exception_Handlers restriction is set. */
7299 gcc_assert (type_annotate_only
7300 || Exception_Mechanism != Setjmp_Longjmp
7301 || No (At_End_Proc (gnat_node))
7302 || Present (Exception_Handlers (gnat_node))
7303 || No_Exception_Handlers_Set ());
7305 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
7306 break;
7308 case N_Exception_Handler:
7309 if (Exception_Mechanism == Setjmp_Longjmp)
7310 gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
7311 else if (Exception_Mechanism == Back_End_Exceptions)
7312 gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
7313 else
7314 gcc_unreachable ();
7315 break;
7317 case N_Raise_Statement:
7318 /* Only for reraise in back-end exceptions mode. */
7319 gcc_assert (No (Name (gnat_node))
7320 && Exception_Mechanism == Back_End_Exceptions);
7322 start_stmt_group ();
7323 gnat_pushlevel ();
7325 /* Clear the current exception pointer so that the occurrence won't be
7326 deallocated. */
7327 gnu_expr = create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE,
7328 ptr_type_node, gnu_incoming_exc_ptr,
7329 false, false, false, false, true, true,
7330 NULL, gnat_node);
7332 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr,
7333 convert (ptr_type_node, integer_zero_node)));
7334 add_stmt (build_call_n_expr (reraise_zcx_decl, 1, gnu_expr));
7335 gnat_poplevel ();
7336 gnu_result = end_stmt_group ();
7337 break;
7339 case N_Push_Constraint_Error_Label:
7340 push_exception_label_stack (&gnu_constraint_error_label_stack,
7341 Exception_Label (gnat_node));
7342 break;
7344 case N_Push_Storage_Error_Label:
7345 push_exception_label_stack (&gnu_storage_error_label_stack,
7346 Exception_Label (gnat_node));
7347 break;
7349 case N_Push_Program_Error_Label:
7350 push_exception_label_stack (&gnu_program_error_label_stack,
7351 Exception_Label (gnat_node));
7352 break;
7354 case N_Pop_Constraint_Error_Label:
7355 gnu_constraint_error_label_stack->pop ();
7356 break;
7358 case N_Pop_Storage_Error_Label:
7359 gnu_storage_error_label_stack->pop ();
7360 break;
7362 case N_Pop_Program_Error_Label:
7363 gnu_program_error_label_stack->pop ();
7364 break;
7366 /******************************/
7367 /* Chapter 12: Generic Units */
7368 /******************************/
7370 case N_Generic_Function_Renaming_Declaration:
7371 case N_Generic_Package_Renaming_Declaration:
7372 case N_Generic_Procedure_Renaming_Declaration:
7373 case N_Generic_Package_Declaration:
7374 case N_Generic_Subprogram_Declaration:
7375 case N_Package_Instantiation:
7376 case N_Procedure_Instantiation:
7377 case N_Function_Instantiation:
7378 /* These nodes can appear on a declaration list but there is nothing to
7379 to be done with them. */
7380 gnu_result = alloc_stmt_list ();
7381 break;
7383 /**************************************************/
7384 /* Chapter 13: Representation Clauses and */
7385 /* Implementation-Dependent Features */
7386 /**************************************************/
7388 case N_Attribute_Definition_Clause:
7389 gnu_result = alloc_stmt_list ();
7391 /* The only one we need to deal with is 'Address since, for the others,
7392 the front-end puts the information elsewhere. */
7393 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
7394 break;
7396 /* And we only deal with 'Address if the object has a Freeze node. */
7397 gnat_temp = Entity (Name (gnat_node));
7398 if (No (Freeze_Node (gnat_temp)))
7399 break;
7401 /* Get the value to use as the address and save it as the equivalent
7402 for the object. When it is frozen, gnat_to_gnu_entity will do the
7403 right thing. */
7404 save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
7405 break;
7407 case N_Enumeration_Representation_Clause:
7408 case N_Record_Representation_Clause:
7409 case N_At_Clause:
7410 /* We do nothing with these. SEM puts the information elsewhere. */
7411 gnu_result = alloc_stmt_list ();
7412 break;
7414 case N_Code_Statement:
7415 if (!type_annotate_only)
7417 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
7418 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
7419 tree gnu_clobbers = NULL_TREE, tail;
7420 bool allows_mem, allows_reg, fake;
7421 int ninputs, noutputs, i;
7422 const char **oconstraints;
7423 const char *constraint;
7424 char *clobber;
7426 /* First retrieve the 3 operand lists built by the front-end. */
7427 Setup_Asm_Outputs (gnat_node);
7428 while (Present (gnat_temp = Asm_Output_Variable ()))
7430 tree gnu_value = gnat_to_gnu (gnat_temp);
7431 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7432 (Asm_Output_Constraint ()));
7434 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
7435 Next_Asm_Output ();
7438 Setup_Asm_Inputs (gnat_node);
7439 while (Present (gnat_temp = Asm_Input_Value ()))
7441 tree gnu_value = gnat_to_gnu (gnat_temp);
7442 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7443 (Asm_Input_Constraint ()));
7445 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
7446 Next_Asm_Input ();
7449 Clobber_Setup (gnat_node);
7450 while ((clobber = Clobber_Get_Next ()))
7451 gnu_clobbers
7452 = tree_cons (NULL_TREE,
7453 build_string (strlen (clobber) + 1, clobber),
7454 gnu_clobbers);
7456 /* Then perform some standard checking and processing on the
7457 operands. In particular, mark them addressable if needed. */
7458 gnu_outputs = nreverse (gnu_outputs);
7459 noutputs = list_length (gnu_outputs);
7460 gnu_inputs = nreverse (gnu_inputs);
7461 ninputs = list_length (gnu_inputs);
7462 oconstraints = XALLOCAVEC (const char *, noutputs);
7464 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
7466 tree output = TREE_VALUE (tail);
7467 constraint
7468 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7469 oconstraints[i] = constraint;
7471 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
7472 &allows_mem, &allows_reg, &fake))
7474 /* If the operand is going to end up in memory,
7475 mark it addressable. Note that we don't test
7476 allows_mem like in the input case below; this
7477 is modelled on the C front-end. */
7478 if (!allows_reg)
7480 output = remove_conversions (output, false);
7481 if (TREE_CODE (output) == CONST_DECL
7482 && DECL_CONST_CORRESPONDING_VAR (output))
7483 output = DECL_CONST_CORRESPONDING_VAR (output);
7484 if (!gnat_mark_addressable (output))
7485 output = error_mark_node;
7488 else
7489 output = error_mark_node;
7491 TREE_VALUE (tail) = output;
7494 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
7496 tree input = TREE_VALUE (tail);
7497 constraint
7498 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7500 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
7501 0, oconstraints,
7502 &allows_mem, &allows_reg))
7504 /* If the operand is going to end up in memory,
7505 mark it addressable. */
7506 if (!allows_reg && allows_mem)
7508 input = remove_conversions (input, false);
7509 if (TREE_CODE (input) == CONST_DECL
7510 && DECL_CONST_CORRESPONDING_VAR (input))
7511 input = DECL_CONST_CORRESPONDING_VAR (input);
7512 if (!gnat_mark_addressable (input))
7513 input = error_mark_node;
7516 else
7517 input = error_mark_node;
7519 TREE_VALUE (tail) = input;
7522 gnu_result = build5 (ASM_EXPR, void_type_node,
7523 gnu_template, gnu_outputs,
7524 gnu_inputs, gnu_clobbers, NULL_TREE);
7525 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
7527 else
7528 gnu_result = alloc_stmt_list ();
7530 break;
7532 /****************/
7533 /* Added Nodes */
7534 /****************/
7536 case N_Expression_With_Actions:
7537 /* This construct doesn't define a scope so we don't push a binding
7538 level around the statement list, but we wrap it in a SAVE_EXPR to
7539 protect it from unsharing. Elaborate the expression as part of the
7540 same statement group as the actions so that the type declaration
7541 gets inserted there as well. This ensures that the type elaboration
7542 code is issued past the actions computing values on which it might
7543 depend. */
7544 start_stmt_group ();
7545 add_stmt_list (Actions (gnat_node));
7546 gnu_expr = gnat_to_gnu (Expression (gnat_node));
7547 gnu_result = end_stmt_group ();
7549 gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
7550 TREE_SIDE_EFFECTS (gnu_result) = 1;
7552 gnu_result
7553 = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
7554 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7555 break;
7557 case N_Freeze_Entity:
7558 start_stmt_group ();
7559 process_freeze_entity (gnat_node);
7560 process_decls (Actions (gnat_node), Empty, Empty, true, true);
7561 gnu_result = end_stmt_group ();
7562 break;
7564 case N_Freeze_Generic_Entity:
7565 gnu_result = alloc_stmt_list ();
7566 break;
7568 case N_Itype_Reference:
7569 if (!present_gnu_tree (Itype (gnat_node)))
7570 process_type (Itype (gnat_node));
7572 gnu_result = alloc_stmt_list ();
7573 break;
7575 case N_Free_Statement:
7576 if (!type_annotate_only)
7578 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
7579 tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
7580 tree gnu_obj_type, gnu_actual_obj_type;
7582 /* If this is a thin pointer, we must first dereference it to create
7583 a fat pointer, then go back below to a thin pointer. The reason
7584 for this is that we need to have a fat pointer someplace in order
7585 to properly compute the size. */
7586 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
7587 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
7588 build_unary_op (INDIRECT_REF, NULL_TREE,
7589 gnu_ptr));
7591 /* If this is a fat pointer, the object must have been allocated with
7592 the template in front of the array. So pass the template address,
7593 and get the total size; do it by converting to a thin pointer. */
7594 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
7595 gnu_ptr
7596 = convert (build_pointer_type
7597 (TYPE_OBJECT_RECORD_TYPE
7598 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
7599 gnu_ptr);
7601 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
7603 /* If this is a thin pointer, the object must have been allocated with
7604 the template in front of the array. So pass the template address,
7605 and get the total size. */
7606 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
7607 gnu_ptr
7608 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
7609 gnu_ptr,
7610 fold_build1 (NEGATE_EXPR, sizetype,
7611 byte_position
7612 (DECL_CHAIN
7613 TYPE_FIELDS ((gnu_obj_type)))));
7615 /* If we have a special dynamic constrained subtype on the node, use
7616 it to compute the size; otherwise, use the designated subtype. */
7617 if (Present (Actual_Designated_Subtype (gnat_node)))
7619 gnu_actual_obj_type
7620 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
7622 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
7623 gnu_actual_obj_type
7624 = build_unc_object_type_from_ptr (gnu_ptr_type,
7625 gnu_actual_obj_type,
7626 get_identifier ("DEALLOC"),
7627 false);
7629 else
7630 gnu_actual_obj_type = gnu_obj_type;
7632 gnu_result
7633 = build_call_alloc_dealloc (gnu_ptr,
7634 TYPE_SIZE_UNIT (gnu_actual_obj_type),
7635 gnu_obj_type,
7636 Procedure_To_Call (gnat_node),
7637 Storage_Pool (gnat_node),
7638 gnat_node);
7640 break;
7642 case N_Raise_Constraint_Error:
7643 case N_Raise_Program_Error:
7644 case N_Raise_Storage_Error:
7645 if (type_annotate_only)
7646 gnu_result = alloc_stmt_list ();
7647 else
7648 gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type);
7649 break;
7651 case N_Validate_Unchecked_Conversion:
7652 /* The only validation we currently do on an unchecked conversion is
7653 that of aliasing assumptions. */
7654 if (flag_strict_aliasing)
7655 gnat_validate_uc_list.safe_push (gnat_node);
7656 gnu_result = alloc_stmt_list ();
7657 break;
7659 case N_Function_Specification:
7660 case N_Procedure_Specification:
7661 case N_Op_Concat:
7662 case N_Component_Association:
7663 case N_Protected_Body:
7664 case N_Task_Body:
7665 /* These nodes should only be present when annotating types. */
7666 gcc_assert (type_annotate_only);
7667 gnu_result = alloc_stmt_list ();
7668 break;
7670 default:
7671 /* Other nodes are not supposed to reach here. */
7672 gcc_unreachable ();
7675 /* If we pushed the processing of the elaboration routine, pop it back. */
7676 if (went_into_elab_proc)
7677 current_function_decl = NULL_TREE;
7679 /* When not optimizing, turn boolean rvalues B into B != false tests
7680 so that the code just below can put the location information of the
7681 reference to B on the inequality operator for better debug info. */
7682 if (!optimize
7683 && TREE_CODE (gnu_result) != INTEGER_CST
7684 && (kind == N_Identifier
7685 || kind == N_Expanded_Name
7686 || kind == N_Explicit_Dereference
7687 || kind == N_Function_Call
7688 || kind == N_Indexed_Component
7689 || kind == N_Selected_Component)
7690 && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
7691 && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
7692 gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
7693 convert (gnu_result_type, gnu_result),
7694 convert (gnu_result_type,
7695 boolean_false_node));
7697 /* Set the location information on the result. Note that we may have
7698 no result if we tried to build a CALL_EXPR node to a procedure with
7699 no side-effects and optimization is enabled. */
7700 if (gnu_result && EXPR_P (gnu_result))
7701 set_gnu_expr_location_from_node (gnu_result, gnat_node);
7703 /* If we're supposed to return something of void_type, it means we have
7704 something we're elaborating for effect, so just return. */
7705 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
7706 return gnu_result;
7708 /* If the result is a constant that overflowed, raise Constraint_Error. */
7709 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
7711 post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
7712 gnu_result
7713 = build1 (NULL_EXPR, gnu_result_type,
7714 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
7715 N_Raise_Constraint_Error));
7718 /* If the result has side-effects and is of an unconstrained type, make a
7719 SAVE_EXPR so that we can be sure it will only be referenced once. But
7720 this is useless for a call to a function that returns an unconstrained
7721 type with default discriminant, as we cannot compute the size of the
7722 actual returned object. We must do this before any conversions. */
7723 if (TREE_SIDE_EFFECTS (gnu_result)
7724 && !(TREE_CODE (gnu_result) == CALL_EXPR
7725 && type_is_padding_self_referential (TREE_TYPE (gnu_result)))
7726 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
7727 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
7728 gnu_result = gnat_protect_expr (gnu_result);
7730 /* Now convert the result to the result type, unless we are in one of the
7731 following cases:
7733 1. If this is the LHS of an assignment or an actual parameter of a
7734 call, return the result almost unmodified since the RHS will have
7735 to be converted to our type in that case, unless the result type
7736 has a simpler size. Likewise if there is just a no-op unchecked
7737 conversion in-between. Similarly, don't convert integral types
7738 that are the operands of an unchecked conversion since we need
7739 to ignore those conversions (for 'Valid).
7741 2. If we have a label (which doesn't have any well-defined type), a
7742 field or an error, return the result almost unmodified. Similarly,
7743 if the two types are record types with the same name, don't convert.
7744 This will be the case when we are converting from a packable version
7745 of a type to its original type and we need those conversions to be
7746 NOPs in order for assignments into these types to work properly.
7748 3. If the type is void or if we have no result, return error_mark_node
7749 to show we have no result.
7751 4. If this is a call to a function that returns with variable size and
7752 the call is used as the expression in either an object or a renaming
7753 declaration, return the result unmodified because we want to use the
7754 return slot optimization in this case.
7756 5. Finally, if the type of the result is already correct. */
7758 if (Present (Parent (gnat_node))
7759 && (lhs_or_actual_p (gnat_node)
7760 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
7761 && unchecked_conversion_nop (Parent (gnat_node)))
7762 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
7763 && !AGGREGATE_TYPE_P (gnu_result_type)
7764 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
7765 && !(TYPE_SIZE (gnu_result_type)
7766 && TYPE_SIZE (TREE_TYPE (gnu_result))
7767 && (AGGREGATE_TYPE_P (gnu_result_type)
7768 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
7769 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
7770 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
7771 != INTEGER_CST))
7772 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
7773 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
7774 && (CONTAINS_PLACEHOLDER_P
7775 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
7776 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
7777 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
7779 /* Remove padding only if the inner object is of self-referential
7780 size: in that case it must be an object of unconstrained type
7781 with a default discriminant and we want to avoid copying too
7782 much data. */
7783 if (type_is_padding_self_referential (TREE_TYPE (gnu_result)))
7784 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
7785 gnu_result);
7788 else if (TREE_CODE (gnu_result) == LABEL_DECL
7789 || TREE_CODE (gnu_result) == FIELD_DECL
7790 || TREE_CODE (gnu_result) == ERROR_MARK
7791 || (TYPE_NAME (gnu_result_type)
7792 == TYPE_NAME (TREE_TYPE (gnu_result))
7793 && TREE_CODE (gnu_result_type) == RECORD_TYPE
7794 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
7796 /* Remove any padding. */
7797 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
7798 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
7799 gnu_result);
7802 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
7803 gnu_result = error_mark_node;
7805 else if (Present (Parent (gnat_node))
7806 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
7807 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration)
7808 && TREE_CODE (gnu_result) == CALL_EXPR
7809 && return_type_with_variable_size_p (TREE_TYPE (gnu_result)))
7812 else if (TREE_TYPE (gnu_result) != gnu_result_type)
7813 gnu_result = convert (gnu_result_type, gnu_result);
7815 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
7816 while ((TREE_CODE (gnu_result) == NOP_EXPR
7817 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
7818 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
7819 gnu_result = TREE_OPERAND (gnu_result, 0);
7821 return gnu_result;
7824 /* Subroutine of above to push the exception label stack. GNU_STACK is
7825 a pointer to the stack to update and GNAT_LABEL, if present, is the
7826 label to push onto the stack. */
7828 static void
7829 push_exception_label_stack (vec<tree, va_gc> **gnu_stack, Entity_Id gnat_label)
7831 tree gnu_label = (Present (gnat_label)
7832 ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
7833 : NULL_TREE);
7835 vec_safe_push (*gnu_stack, gnu_label);
7838 /* Record the current code position in GNAT_NODE. */
7840 static void
7841 record_code_position (Node_Id gnat_node)
7843 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
7845 add_stmt_with_node (stmt_stmt, gnat_node);
7846 save_gnu_tree (gnat_node, stmt_stmt, true);
7849 /* Insert the code for GNAT_NODE at the position saved for that node. */
7851 static void
7852 insert_code_for (Node_Id gnat_node)
7854 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
7855 save_gnu_tree (gnat_node, NULL_TREE, true);
7858 /* Start a new statement group chained to the previous group. */
7860 void
7861 start_stmt_group (void)
7863 struct stmt_group *group = stmt_group_free_list;
7865 /* First see if we can get one from the free list. */
7866 if (group)
7867 stmt_group_free_list = group->previous;
7868 else
7869 group = ggc_alloc<stmt_group> ();
7871 group->previous = current_stmt_group;
7872 group->stmt_list = group->block = group->cleanups = NULL_TREE;
7873 current_stmt_group = group;
7876 /* Add GNU_STMT to the current statement group. If it is an expression with
7877 no effects, it is ignored. */
7879 void
7880 add_stmt (tree gnu_stmt)
7882 append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
7885 /* Similar, but the statement is always added, regardless of side-effects. */
7887 void
7888 add_stmt_force (tree gnu_stmt)
7890 append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
7893 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
7895 void
7896 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
7898 /* Do not emit a location for renamings that come from generic instantiation,
7899 they are likely to disturb debugging. */
7900 if (Present (gnat_node)
7901 && !renaming_from_generic_instantiation_p (gnat_node))
7902 set_expr_location_from_node (gnu_stmt, gnat_node);
7903 add_stmt (gnu_stmt);
7906 /* Similar, but the statement is always added, regardless of side-effects. */
7908 void
7909 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
7911 if (Present (gnat_node))
7912 set_expr_location_from_node (gnu_stmt, gnat_node);
7913 add_stmt_force (gnu_stmt);
7916 /* Add a declaration statement for GNU_DECL to the current statement group.
7917 Get SLOC from Entity_Id. */
7919 void
7920 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
7922 tree type = TREE_TYPE (gnu_decl);
7923 tree gnu_stmt, gnu_init, t;
7925 /* If this is a variable that Gigi is to ignore, we may have been given
7926 an ERROR_MARK. So test for it. We also might have been given a
7927 reference for a renaming. So only do something for a decl. Also
7928 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
7929 if (!DECL_P (gnu_decl)
7930 || (TREE_CODE (gnu_decl) == TYPE_DECL
7931 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
7932 return;
7934 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
7936 /* If we are external or global, we don't want to output the DECL_EXPR for
7937 this DECL node since we already have evaluated the expressions in the
7938 sizes and positions as globals and doing it again would be wrong. */
7939 if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ())
7941 /* Mark everything as used to prevent node sharing with subprograms.
7942 Note that walk_tree knows how to deal with TYPE_DECL, but neither
7943 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
7944 MARK_VISITED (gnu_stmt);
7945 if (TREE_CODE (gnu_decl) == VAR_DECL
7946 || TREE_CODE (gnu_decl) == CONST_DECL)
7948 MARK_VISITED (DECL_SIZE (gnu_decl));
7949 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
7950 MARK_VISITED (DECL_INITIAL (gnu_decl));
7952 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
7953 else if (TREE_CODE (gnu_decl) == TYPE_DECL
7954 && RECORD_OR_UNION_TYPE_P (type)
7955 && !TYPE_FAT_POINTER_P (type))
7956 MARK_VISITED (TYPE_ADA_SIZE (type));
7958 else
7959 add_stmt_with_node (gnu_stmt, gnat_entity);
7961 /* If this is a variable and an initializer is attached to it, it must be
7962 valid for the context. Similar to init_const in create_var_decl. */
7963 if (TREE_CODE (gnu_decl) == VAR_DECL
7964 && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
7965 && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
7966 || (TREE_STATIC (gnu_decl)
7967 && !initializer_constant_valid_p (gnu_init,
7968 TREE_TYPE (gnu_init)))))
7970 /* If GNU_DECL has a padded type, convert it to the unpadded
7971 type so the assignment is done properly. */
7972 if (TYPE_IS_PADDING_P (type))
7973 t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
7974 else
7975 t = gnu_decl;
7977 gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
7979 DECL_INITIAL (gnu_decl) = NULL_TREE;
7980 if (TREE_READONLY (gnu_decl))
7982 TREE_READONLY (gnu_decl) = 0;
7983 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
7986 add_stmt_with_node (gnu_stmt, gnat_entity);
7990 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
7992 static tree
7993 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
7995 tree t = *tp;
7997 if (TREE_VISITED (t))
7998 *walk_subtrees = 0;
8000 /* Don't mark a dummy type as visited because we want to mark its sizes
8001 and fields once it's filled in. */
8002 else if (!TYPE_IS_DUMMY_P (t))
8003 TREE_VISITED (t) = 1;
8005 if (TYPE_P (t))
8006 TYPE_SIZES_GIMPLIFIED (t) = 1;
8008 return NULL_TREE;
8011 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8012 sized gimplified. We use this to indicate all variable sizes and
8013 positions in global types may not be shared by any subprogram. */
8015 void
8016 mark_visited (tree t)
8018 walk_tree (&t, mark_visited_r, NULL, NULL);
8021 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8022 set its location to that of GNAT_NODE if present, but with column info
8023 cleared so that conditional branches generated as part of the cleanup
8024 code do not interfere with coverage analysis tools. */
8026 static void
8027 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
8029 if (Present (gnat_node))
8030 set_expr_location_from_node (gnu_cleanup, gnat_node, true);
8031 append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
8034 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8036 void
8037 set_block_for_group (tree gnu_block)
8039 gcc_assert (!current_stmt_group->block);
8040 current_stmt_group->block = gnu_block;
8043 /* Return code corresponding to the current code group. It is normally
8044 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
8045 BLOCK or cleanups were set. */
8047 tree
8048 end_stmt_group (void)
8050 struct stmt_group *group = current_stmt_group;
8051 tree gnu_retval = group->stmt_list;
8053 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
8054 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
8055 make a BIND_EXPR. Note that we nest in that because the cleanup may
8056 reference variables in the block. */
8057 if (gnu_retval == NULL_TREE)
8058 gnu_retval = alloc_stmt_list ();
8060 if (group->cleanups)
8061 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
8062 group->cleanups);
8064 if (current_stmt_group->block)
8065 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
8066 gnu_retval, group->block);
8068 /* Remove this group from the stack and add it to the free list. */
8069 current_stmt_group = group->previous;
8070 group->previous = stmt_group_free_list;
8071 stmt_group_free_list = group;
8073 return gnu_retval;
8076 /* Return whether the current statement group may fall through. */
8078 static inline bool
8079 stmt_group_may_fallthru (void)
8081 if (current_stmt_group->stmt_list)
8082 return block_may_fallthru (current_stmt_group->stmt_list);
8083 else
8084 return true;
8087 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
8088 statements.*/
8090 static void
8091 add_stmt_list (List_Id gnat_list)
8093 Node_Id gnat_node;
8095 if (Present (gnat_list))
8096 for (gnat_node = First (gnat_list); Present (gnat_node);
8097 gnat_node = Next (gnat_node))
8098 add_stmt (gnat_to_gnu (gnat_node));
8101 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
8102 If BINDING_P is true, push and pop a binding level around the list. */
8104 static tree
8105 build_stmt_group (List_Id gnat_list, bool binding_p)
8107 start_stmt_group ();
8109 if (binding_p)
8110 gnat_pushlevel ();
8112 add_stmt_list (gnat_list);
8114 if (binding_p)
8115 gnat_poplevel ();
8117 return end_stmt_group ();
8120 /* Generate GIMPLE in place for the expression at *EXPR_P. */
8123 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
8124 gimple_seq *post_p ATTRIBUTE_UNUSED)
8126 tree expr = *expr_p;
8127 tree type = TREE_TYPE (expr);
8128 tree op;
8130 if (IS_ADA_STMT (expr))
8131 return gnat_gimplify_stmt (expr_p);
8133 switch (TREE_CODE (expr))
8135 case NULL_EXPR:
8136 /* If this is an aggregate type, build a null pointer of the appropriate
8137 type and dereference it. */
8138 if (AGGREGATE_TYPE_P (type)
8139 || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
8140 *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE,
8141 convert (build_pointer_type (type),
8142 integer_zero_node));
8143 /* Otherwise, just make a VAR_DECL. */
8144 else
8146 *expr_p = create_tmp_var (type, NULL);
8147 TREE_NO_WARNING (*expr_p) = 1;
8150 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
8151 return GS_OK;
8153 case UNCONSTRAINED_ARRAY_REF:
8154 /* We should only do this if we are just elaborating for side-effects,
8155 but we can't know that yet. */
8156 *expr_p = TREE_OPERAND (*expr_p, 0);
8157 return GS_OK;
8159 case ADDR_EXPR:
8160 op = TREE_OPERAND (expr, 0);
8162 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
8163 is put into static memory. We know that it's going to be read-only
8164 given the semantics we have and it must be in static memory when the
8165 reference is in an elaboration procedure. */
8166 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
8168 tree addr = build_fold_addr_expr (tree_output_constant_def (op));
8169 *expr_p = fold_convert (type, addr);
8170 return GS_ALL_DONE;
8173 /* Replace atomic loads with their first argument. That's necessary
8174 because the gimplifier would create a temporary otherwise. */
8175 if (TREE_SIDE_EFFECTS (op))
8176 while (handled_component_p (op) || CONVERT_EXPR_P (op))
8178 tree inner = TREE_OPERAND (op, 0);
8179 if (TREE_CODE (inner) == CALL_EXPR && call_is_atomic_load (inner))
8181 tree t = CALL_EXPR_ARG (inner, 0);
8182 if (TREE_CODE (t) == NOP_EXPR)
8183 t = TREE_OPERAND (t, 0);
8184 if (TREE_CODE (t) == ADDR_EXPR)
8185 TREE_OPERAND (op, 0) = TREE_OPERAND (t, 0);
8186 else
8187 TREE_OPERAND (op, 0) = build_fold_indirect_ref (t);
8189 else
8190 op = inner;
8193 return GS_UNHANDLED;
8195 case VIEW_CONVERT_EXPR:
8196 op = TREE_OPERAND (expr, 0);
8198 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
8199 type to a scalar one, explicitly create the local temporary. That's
8200 required if the type is passed by reference. */
8201 if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
8202 && AGGREGATE_TYPE_P (TREE_TYPE (op))
8203 && !AGGREGATE_TYPE_P (type))
8205 tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
8206 gimple_add_tmp_var (new_var);
8208 mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
8209 gimplify_and_add (mod, pre_p);
8211 TREE_OPERAND (expr, 0) = new_var;
8212 return GS_OK;
8215 return GS_UNHANDLED;
8217 case DECL_EXPR:
8218 op = DECL_EXPR_DECL (expr);
8220 /* The expressions for the RM bounds must be gimplified to ensure that
8221 they are properly elaborated. See gimplify_decl_expr. */
8222 if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
8223 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
8224 switch (TREE_CODE (TREE_TYPE (op)))
8226 case INTEGER_TYPE:
8227 case ENUMERAL_TYPE:
8228 case BOOLEAN_TYPE:
8229 case REAL_TYPE:
8231 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
8233 val = TYPE_RM_MIN_VALUE (type);
8234 if (val)
8236 gimplify_one_sizepos (&val, pre_p);
8237 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8238 SET_TYPE_RM_MIN_VALUE (t, val);
8241 val = TYPE_RM_MAX_VALUE (type);
8242 if (val)
8244 gimplify_one_sizepos (&val, pre_p);
8245 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8246 SET_TYPE_RM_MAX_VALUE (t, val);
8250 break;
8252 default:
8253 break;
8256 /* ... fall through ... */
8258 default:
8259 return GS_UNHANDLED;
8263 /* Generate GIMPLE in place for the statement at *STMT_P. */
8265 static enum gimplify_status
8266 gnat_gimplify_stmt (tree *stmt_p)
8268 tree stmt = *stmt_p;
8270 switch (TREE_CODE (stmt))
8272 case STMT_STMT:
8273 *stmt_p = STMT_STMT_STMT (stmt);
8274 return GS_OK;
8276 case LOOP_STMT:
8278 tree gnu_start_label = create_artificial_label (input_location);
8279 tree gnu_cond = LOOP_STMT_COND (stmt);
8280 tree gnu_update = LOOP_STMT_UPDATE (stmt);
8281 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
8283 /* Build the condition expression from the test, if any. */
8284 if (gnu_cond)
8286 /* Deal with the optimization hints. */
8287 if (LOOP_STMT_IVDEP (stmt))
8288 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8289 build_int_cst (integer_type_node,
8290 annot_expr_ivdep_kind));
8291 if (LOOP_STMT_NO_VECTOR (stmt))
8292 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8293 build_int_cst (integer_type_node,
8294 annot_expr_no_vector_kind));
8295 if (LOOP_STMT_VECTOR (stmt))
8296 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8297 build_int_cst (integer_type_node,
8298 annot_expr_vector_kind));
8300 gnu_cond
8301 = build3 (COND_EXPR, void_type_node, gnu_cond, NULL_TREE,
8302 build1 (GOTO_EXPR, void_type_node, gnu_end_label));
8305 /* Set to emit the statements of the loop. */
8306 *stmt_p = NULL_TREE;
8308 /* We first emit the start label and then a conditional jump to the
8309 end label if there's a top condition, then the update if it's at
8310 the top, then the body of the loop, then a conditional jump to
8311 the end label if there's a bottom condition, then the update if
8312 it's at the bottom, and finally a jump to the start label and the
8313 definition of the end label. */
8314 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
8315 gnu_start_label),
8316 stmt_p);
8318 if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
8319 append_to_statement_list (gnu_cond, stmt_p);
8321 if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
8322 append_to_statement_list (gnu_update, stmt_p);
8324 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
8326 if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
8327 append_to_statement_list (gnu_cond, stmt_p);
8329 if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
8330 append_to_statement_list (gnu_update, stmt_p);
8332 tree t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
8333 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
8334 append_to_statement_list (t, stmt_p);
8336 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
8337 gnu_end_label),
8338 stmt_p);
8339 return GS_OK;
8342 case EXIT_STMT:
8343 /* Build a statement to jump to the corresponding end label, then
8344 see if it needs to be conditional. */
8345 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
8346 if (EXIT_STMT_COND (stmt))
8347 *stmt_p = build3 (COND_EXPR, void_type_node,
8348 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
8349 return GS_OK;
8351 default:
8352 gcc_unreachable ();
8356 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
8358 This routine is exclusively called in type_annotate mode, to compute DDA
8359 information for types in withed units, for ASIS use. */
8361 static void
8362 elaborate_all_entities_for_package (Entity_Id gnat_package)
8364 Entity_Id gnat_entity;
8366 for (gnat_entity = First_Entity (gnat_package);
8367 Present (gnat_entity);
8368 gnat_entity = Next_Entity (gnat_entity))
8370 const Entity_Kind kind = Ekind (gnat_entity);
8372 /* We are interested only in entities visible from the main unit. */
8373 if (!Is_Public (gnat_entity))
8374 continue;
8376 /* Skip stuff internal to the compiler. */
8377 if (Convention (gnat_entity) == Convention_Intrinsic)
8378 continue;
8379 if (kind == E_Operator)
8380 continue;
8381 if (IN (kind, Subprogram_Kind) && Is_Intrinsic_Subprogram (gnat_entity))
8382 continue;
8384 /* Skip named numbers. */
8385 if (IN (kind, Named_Kind))
8386 continue;
8388 /* Skip generic declarations. */
8389 if (IN (kind, Generic_Unit_Kind))
8390 continue;
8392 /* Skip package bodies. */
8393 if (kind == E_Package_Body)
8394 continue;
8396 /* Skip limited views that point back to the main unit. */
8397 if (IN (kind, Incomplete_Kind)
8398 && From_Limited_With (gnat_entity)
8399 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity)))
8400 continue;
8402 /* Skip types that aren't frozen. */
8403 if (IN (kind, Type_Kind) && !Is_Frozen (gnat_entity))
8404 continue;
8406 /* Recurse on real packages that aren't in the main unit. */
8407 if (kind == E_Package)
8409 if (No (Renamed_Entity (gnat_entity))
8410 && !In_Extended_Main_Code_Unit (gnat_entity))
8411 elaborate_all_entities_for_package (gnat_entity);
8413 else
8414 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
8418 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
8419 Operate recursively but check that we aren't elaborating something more
8420 than once.
8422 This routine is exclusively called in type_annotate mode, to compute DDA
8423 information for types in withed units, for ASIS use. */
8425 static void
8426 elaborate_all_entities (Node_Id gnat_node)
8428 Entity_Id gnat_with_clause;
8430 /* Process each unit only once. As we trace the context of all relevant
8431 units transitively, including generic bodies, we may encounter the
8432 same generic unit repeatedly. */
8433 if (!present_gnu_tree (gnat_node))
8434 save_gnu_tree (gnat_node, integer_zero_node, true);
8436 /* Save entities in all context units. A body may have an implicit_with
8437 on its own spec, if the context includes a child unit, so don't save
8438 the spec twice. */
8439 for (gnat_with_clause = First (Context_Items (gnat_node));
8440 Present (gnat_with_clause);
8441 gnat_with_clause = Next (gnat_with_clause))
8442 if (Nkind (gnat_with_clause) == N_With_Clause
8443 && !present_gnu_tree (Library_Unit (gnat_with_clause))
8444 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
8446 Node_Id gnat_unit = Library_Unit (gnat_with_clause);
8447 Entity_Id gnat_entity = Entity (Name (gnat_with_clause));
8449 elaborate_all_entities (gnat_unit);
8451 if (Ekind (gnat_entity) == E_Package)
8452 elaborate_all_entities_for_package (gnat_entity);
8454 else if (Ekind (gnat_entity) == E_Generic_Package)
8456 Node_Id gnat_body = Corresponding_Body (Unit (gnat_unit));
8458 /* Retrieve compilation unit node of generic body. */
8459 while (Present (gnat_body)
8460 && Nkind (gnat_body) != N_Compilation_Unit)
8461 gnat_body = Parent (gnat_body);
8463 /* If body is available, elaborate its context. */
8464 if (Present (gnat_body))
8465 elaborate_all_entities (gnat_body);
8469 if (Nkind (Unit (gnat_node)) == N_Package_Body)
8470 elaborate_all_entities (Library_Unit (gnat_node));
8473 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
8475 static void
8476 process_freeze_entity (Node_Id gnat_node)
8478 const Entity_Id gnat_entity = Entity (gnat_node);
8479 const Entity_Kind kind = Ekind (gnat_entity);
8480 tree gnu_old, gnu_new;
8482 /* If this is a package, we need to generate code for the package. */
8483 if (kind == E_Package)
8485 insert_code_for
8486 (Parent (Corresponding_Body
8487 (Parent (Declaration_Node (gnat_entity)))));
8488 return;
8491 /* Don't do anything for class-wide types as they are always transformed
8492 into their root type. */
8493 if (kind == E_Class_Wide_Type)
8494 return;
8496 /* Check for an old definition. This freeze node might be for an Itype. */
8497 gnu_old
8498 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
8500 /* If this entity has an address representation clause, GNU_OLD is the
8501 address, so discard it here. */
8502 if (Present (Address_Clause (gnat_entity)))
8503 gnu_old = NULL_TREE;
8505 /* Don't do anything for subprograms that may have been elaborated before
8506 their freeze nodes. This can happen, for example, because of an inner
8507 call in an instance body or because of previous compilation of a spec
8508 for inlining purposes. */
8509 if (gnu_old
8510 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
8511 && (kind == E_Function || kind == E_Procedure))
8512 || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
8513 && kind == E_Subprogram_Type)))
8514 return;
8516 /* If we have a non-dummy type old tree, we have nothing to do, except
8517 aborting if this is the public view of a private type whose full view was
8518 not delayed, as this node was never delayed as it should have been. We
8519 let this happen for concurrent types and their Corresponding_Record_Type,
8520 however, because each might legitimately be elaborated before its own
8521 freeze node, e.g. while processing the other. */
8522 if (gnu_old
8523 && !(TREE_CODE (gnu_old) == TYPE_DECL
8524 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
8526 gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
8527 && Present (Full_View (gnat_entity))
8528 && No (Freeze_Node (Full_View (gnat_entity))))
8529 || Is_Concurrent_Type (gnat_entity)
8530 || (IN (kind, Record_Kind)
8531 && Is_Concurrent_Record_Type (gnat_entity)));
8532 return;
8535 /* Reset the saved tree, if any, and elaborate the object or type for real.
8536 If there is a full view, elaborate it and use the result. And, if this
8537 is the root type of a class-wide type, reuse it for the latter. */
8538 if (gnu_old)
8540 save_gnu_tree (gnat_entity, NULL_TREE, false);
8542 if (IN (kind, Incomplete_Or_Private_Kind)
8543 && Present (Full_View (gnat_entity)))
8545 Entity_Id full_view = Full_View (gnat_entity);
8547 save_gnu_tree (full_view, NULL_TREE, false);
8549 if (IN (Ekind (full_view), Private_Kind)
8550 && Present (Underlying_Full_View (full_view)))
8552 full_view = Underlying_Full_View (full_view);
8553 save_gnu_tree (full_view, NULL_TREE, false);
8557 if (IN (kind, Type_Kind)
8558 && Present (Class_Wide_Type (gnat_entity))
8559 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
8560 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
8563 if (IN (kind, Incomplete_Or_Private_Kind)
8564 && Present (Full_View (gnat_entity)))
8566 Entity_Id full_view = Full_View (gnat_entity);
8568 if (IN (Ekind (full_view), Private_Kind)
8569 && Present (Underlying_Full_View (full_view)))
8570 full_view = Underlying_Full_View (full_view);
8572 gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, 1);
8574 /* Propagate back-annotations from full view to partial view. */
8575 if (Unknown_Alignment (gnat_entity))
8576 Set_Alignment (gnat_entity, Alignment (full_view));
8578 if (Unknown_Esize (gnat_entity))
8579 Set_Esize (gnat_entity, Esize (full_view));
8581 if (Unknown_RM_Size (gnat_entity))
8582 Set_RM_Size (gnat_entity, RM_Size (full_view));
8584 /* The above call may have defined this entity (the simplest example
8585 of this is when we have a private enumeral type since the bounds
8586 will have the public view). */
8587 if (!present_gnu_tree (gnat_entity))
8588 save_gnu_tree (gnat_entity, gnu_new, false);
8590 else
8592 tree gnu_init
8593 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
8594 && present_gnu_tree (Declaration_Node (gnat_entity)))
8595 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
8597 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
8600 if (IN (kind, Type_Kind)
8601 && Present (Class_Wide_Type (gnat_entity))
8602 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
8603 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
8605 /* If we have an old type and we've made pointers to this type, update those
8606 pointers. If this is a Taft amendment type in the main unit, we need to
8607 mark the type as used since other units referencing it don't see the full
8608 declaration and, therefore, cannot mark it as used themselves. */
8609 if (gnu_old)
8611 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
8612 TREE_TYPE (gnu_new));
8613 if (DECL_TAFT_TYPE_P (gnu_old))
8614 used_types_insert (TREE_TYPE (gnu_new));
8618 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
8619 We make two passes, one to elaborate anything other than bodies (but
8620 we declare a function if there was no spec). The second pass
8621 elaborates the bodies.
8623 GNAT_END_LIST gives the element in the list past the end. Normally,
8624 this is Empty, but can be First_Real_Statement for a
8625 Handled_Sequence_Of_Statements.
8627 We make a complete pass through both lists if PASS1P is true, then make
8628 the second pass over both lists if PASS2P is true. The lists usually
8629 correspond to the public and private parts of a package. */
8631 static void
8632 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
8633 Node_Id gnat_end_list, bool pass1p, bool pass2p)
8635 List_Id gnat_decl_array[2];
8636 Node_Id gnat_decl;
8637 int i;
8639 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
8641 if (pass1p)
8642 for (i = 0; i <= 1; i++)
8643 if (Present (gnat_decl_array[i]))
8644 for (gnat_decl = First (gnat_decl_array[i]);
8645 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
8647 /* For package specs, we recurse inside the declarations,
8648 thus taking the two pass approach inside the boundary. */
8649 if (Nkind (gnat_decl) == N_Package_Declaration
8650 && (Nkind (Specification (gnat_decl)
8651 == N_Package_Specification)))
8652 process_decls (Visible_Declarations (Specification (gnat_decl)),
8653 Private_Declarations (Specification (gnat_decl)),
8654 Empty, true, false);
8656 /* Similarly for any declarations in the actions of a
8657 freeze node. */
8658 else if (Nkind (gnat_decl) == N_Freeze_Entity)
8660 process_freeze_entity (gnat_decl);
8661 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
8664 /* Package bodies with freeze nodes get their elaboration deferred
8665 until the freeze node, but the code must be placed in the right
8666 place, so record the code position now. */
8667 else if (Nkind (gnat_decl) == N_Package_Body
8668 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
8669 record_code_position (gnat_decl);
8671 else if (Nkind (gnat_decl) == N_Package_Body_Stub
8672 && Present (Library_Unit (gnat_decl))
8673 && Present (Freeze_Node
8674 (Corresponding_Spec
8675 (Proper_Body (Unit
8676 (Library_Unit (gnat_decl)))))))
8677 record_code_position
8678 (Proper_Body (Unit (Library_Unit (gnat_decl))));
8680 /* We defer most subprogram bodies to the second pass. */
8681 else if (Nkind (gnat_decl) == N_Subprogram_Body)
8683 if (Acts_As_Spec (gnat_decl))
8685 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
8687 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
8688 && Ekind (gnat_subprog_id) != E_Generic_Function)
8689 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
8693 /* For bodies and stubs that act as their own specs, the entity
8694 itself must be elaborated in the first pass, because it may
8695 be used in other declarations. */
8696 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
8698 Node_Id gnat_subprog_id
8699 = Defining_Entity (Specification (gnat_decl));
8701 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
8702 && Ekind (gnat_subprog_id) != E_Generic_Procedure
8703 && Ekind (gnat_subprog_id) != E_Generic_Function)
8704 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
8707 /* Concurrent stubs stand for the corresponding subprogram bodies,
8708 which are deferred like other bodies. */
8709 else if (Nkind (gnat_decl) == N_Task_Body_Stub
8710 || Nkind (gnat_decl) == N_Protected_Body_Stub)
8713 /* Renamed subprograms may not be elaborated yet at this point
8714 since renamings do not trigger freezing. Wait for the second
8715 pass to take care of them. */
8716 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
8719 else
8720 add_stmt (gnat_to_gnu (gnat_decl));
8723 /* Here we elaborate everything we deferred above except for package bodies,
8724 which are elaborated at their freeze nodes. Note that we must also
8725 go inside things (package specs and freeze nodes) the first pass did. */
8726 if (pass2p)
8727 for (i = 0; i <= 1; i++)
8728 if (Present (gnat_decl_array[i]))
8729 for (gnat_decl = First (gnat_decl_array[i]);
8730 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
8732 if (Nkind (gnat_decl) == N_Subprogram_Body
8733 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
8734 || Nkind (gnat_decl) == N_Task_Body_Stub
8735 || Nkind (gnat_decl) == N_Protected_Body_Stub)
8736 add_stmt (gnat_to_gnu (gnat_decl));
8738 else if (Nkind (gnat_decl) == N_Package_Declaration
8739 && (Nkind (Specification (gnat_decl)
8740 == N_Package_Specification)))
8741 process_decls (Visible_Declarations (Specification (gnat_decl)),
8742 Private_Declarations (Specification (gnat_decl)),
8743 Empty, false, true);
8745 else if (Nkind (gnat_decl) == N_Freeze_Entity)
8746 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
8748 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
8749 add_stmt (gnat_to_gnu (gnat_decl));
8753 /* Make a unary operation of kind CODE using build_unary_op, but guard
8754 the operation by an overflow check. CODE can be one of NEGATE_EXPR
8755 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
8756 the operation is to be performed in that type. GNAT_NODE is the gnat
8757 node conveying the source location for which the error should be
8758 signaled. */
8760 static tree
8761 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
8762 Node_Id gnat_node)
8764 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
8766 operand = gnat_protect_expr (operand);
8768 return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
8769 operand, TYPE_MIN_VALUE (gnu_type)),
8770 build_unary_op (code, gnu_type, operand),
8771 CE_Overflow_Check_Failed, gnat_node);
8774 /* Make a binary operation of kind CODE using build_binary_op, but guard
8775 the operation by an overflow check. CODE can be one of PLUS_EXPR,
8776 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
8777 Usually the operation is to be performed in that type. GNAT_NODE is
8778 the GNAT node conveying the source location for which the error should
8779 be signaled. */
8781 static tree
8782 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
8783 tree right, Node_Id gnat_node)
8785 const unsigned int precision = TYPE_PRECISION (gnu_type);
8786 tree lhs = gnat_protect_expr (left);
8787 tree rhs = gnat_protect_expr (right);
8788 tree type_max = TYPE_MAX_VALUE (gnu_type);
8789 tree type_min = TYPE_MIN_VALUE (gnu_type);
8790 tree zero = convert (gnu_type, integer_zero_node);
8791 tree gnu_expr, rhs_lt_zero, tmp1, tmp2;
8792 tree check_pos, check_neg, check;
8794 /* Assert that the precision is a power of 2. */
8795 gcc_assert ((precision & (precision - 1)) == 0);
8797 /* Prefer a constant or known-positive rhs to simplify checks. */
8798 if (!TREE_CONSTANT (rhs)
8799 && commutative_tree_code (code)
8800 && (TREE_CONSTANT (lhs)
8801 || (!tree_expr_nonnegative_p (rhs)
8802 && tree_expr_nonnegative_p (lhs))))
8804 tree tmp = lhs;
8805 lhs = rhs;
8806 rhs = tmp;
8809 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
8811 /* If we can fold the expression to a constant, just return it.
8812 The caller will deal with overflow, no need to generate a check. */
8813 if (TREE_CONSTANT (gnu_expr))
8814 return gnu_expr;
8816 rhs_lt_zero = tree_expr_nonnegative_p (rhs)
8817 ? boolean_false_node
8818 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
8820 /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
8822 /* Try a few strategies that may be cheaper than the general
8823 code at the end of the function, if the rhs is not known.
8824 The strategies are:
8825 - Call library function for 64-bit multiplication (complex)
8826 - Widen, if input arguments are sufficiently small
8827 - Determine overflow using wrapped result for addition/subtraction. */
8829 if (!TREE_CONSTANT (rhs))
8831 /* Even for add/subtract double size to get another base type. */
8832 const unsigned int needed_precision = precision * 2;
8834 if (code == MULT_EXPR && precision == 64)
8836 tree int_64 = gnat_type_for_size (64, 0);
8838 return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
8839 convert (int_64, lhs),
8840 convert (int_64, rhs)));
8843 if (needed_precision <= BITS_PER_WORD
8844 || (code == MULT_EXPR && needed_precision <= LONG_LONG_TYPE_SIZE))
8846 tree wide_type = gnat_type_for_size (needed_precision, 0);
8847 tree wide_result = build_binary_op (code, wide_type,
8848 convert (wide_type, lhs),
8849 convert (wide_type, rhs));
8851 check = build_binary_op
8852 (TRUTH_ORIF_EXPR, boolean_type_node,
8853 build_binary_op (LT_EXPR, boolean_type_node, wide_result,
8854 convert (wide_type, type_min)),
8855 build_binary_op (GT_EXPR, boolean_type_node, wide_result,
8856 convert (wide_type, type_max)));
8858 return
8859 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
8862 if (code == PLUS_EXPR || code == MINUS_EXPR)
8864 tree unsigned_type = gnat_type_for_size (precision, 1);
8865 tree wrapped_expr
8866 = convert (gnu_type,
8867 build_binary_op (code, unsigned_type,
8868 convert (unsigned_type, lhs),
8869 convert (unsigned_type, rhs)));
8871 /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
8872 or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
8873 check
8874 = build_binary_op (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
8875 build_binary_op (code == PLUS_EXPR
8876 ? LT_EXPR : GT_EXPR,
8877 boolean_type_node,
8878 wrapped_expr, lhs));
8880 return
8881 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
8885 switch (code)
8887 case PLUS_EXPR:
8888 /* When rhs >= 0, overflow when lhs > type_max - rhs. */
8889 check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
8890 build_binary_op (MINUS_EXPR, gnu_type,
8891 type_max, rhs)),
8893 /* When rhs < 0, overflow when lhs < type_min - rhs. */
8894 check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
8895 build_binary_op (MINUS_EXPR, gnu_type,
8896 type_min, rhs));
8897 break;
8899 case MINUS_EXPR:
8900 /* When rhs >= 0, overflow when lhs < type_min + rhs. */
8901 check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
8902 build_binary_op (PLUS_EXPR, gnu_type,
8903 type_min, rhs)),
8905 /* When rhs < 0, overflow when lhs > type_max + rhs. */
8906 check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
8907 build_binary_op (PLUS_EXPR, gnu_type,
8908 type_max, rhs));
8909 break;
8911 case MULT_EXPR:
8912 /* The check here is designed to be efficient if the rhs is constant,
8913 but it will work for any rhs by using integer division.
8914 Four different check expressions determine whether X * C overflows,
8915 depending on C.
8916 C == 0 => false
8917 C > 0 => X > type_max / C || X < type_min / C
8918 C == -1 => X == type_min
8919 C < -1 => X > type_min / C || X < type_max / C */
8921 tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
8922 tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
8924 check_pos
8925 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
8926 build_binary_op (NE_EXPR, boolean_type_node, zero,
8927 rhs),
8928 build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8929 build_binary_op (GT_EXPR,
8930 boolean_type_node,
8931 lhs, tmp1),
8932 build_binary_op (LT_EXPR,
8933 boolean_type_node,
8934 lhs, tmp2)));
8936 check_neg
8937 = fold_build3 (COND_EXPR, boolean_type_node,
8938 build_binary_op (EQ_EXPR, boolean_type_node, rhs,
8939 build_int_cst (gnu_type, -1)),
8940 build_binary_op (EQ_EXPR, boolean_type_node, lhs,
8941 type_min),
8942 build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8943 build_binary_op (GT_EXPR,
8944 boolean_type_node,
8945 lhs, tmp2),
8946 build_binary_op (LT_EXPR,
8947 boolean_type_node,
8948 lhs, tmp1)));
8949 break;
8951 default:
8952 gcc_unreachable();
8955 check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
8956 check_pos);
8958 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
8961 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
8962 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
8963 which we have to check. GNAT_NODE is the GNAT node conveying the source
8964 location for which the error should be signaled. */
8966 static tree
8967 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
8969 tree gnu_range_type = get_unpadded_type (gnat_range_type);
8970 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
8972 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
8973 This can for example happen when translating 'Val or 'Value. */
8974 if (gnu_compare_type == gnu_range_type)
8975 return gnu_expr;
8977 /* Range checks can only be applied to types with ranges. */
8978 gcc_assert (INTEGRAL_TYPE_P (gnu_range_type)
8979 || SCALAR_FLOAT_TYPE_P (gnu_range_type));
8981 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
8982 we can't do anything since we might be truncating the bounds. No
8983 check is needed in this case. */
8984 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
8985 && (TYPE_PRECISION (gnu_compare_type)
8986 < TYPE_PRECISION (get_base_type (gnu_range_type))))
8987 return gnu_expr;
8989 /* Checked expressions must be evaluated only once. */
8990 gnu_expr = gnat_protect_expr (gnu_expr);
8992 /* Note that the form of the check is
8993 (not (expr >= lo)) or (not (expr <= hi))
8994 the reason for this slightly convoluted form is that NaNs
8995 are not considered to be in range in the float case. */
8996 return emit_check
8997 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8998 invert_truthvalue
8999 (build_binary_op (GE_EXPR, boolean_type_node,
9000 convert (gnu_compare_type, gnu_expr),
9001 convert (gnu_compare_type,
9002 TYPE_MIN_VALUE
9003 (gnu_range_type)))),
9004 invert_truthvalue
9005 (build_binary_op (LE_EXPR, boolean_type_node,
9006 convert (gnu_compare_type, gnu_expr),
9007 convert (gnu_compare_type,
9008 TYPE_MAX_VALUE
9009 (gnu_range_type))))),
9010 gnu_expr, CE_Range_Check_Failed, gnat_node);
9013 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which
9014 we are about to index, GNU_EXPR is the index expression to be checked,
9015 GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
9016 has to be checked. Note that for index checking we cannot simply use the
9017 emit_range_check function (although very similar code needs to be generated
9018 in both cases) since for index checking the array type against which we are
9019 checking the indices may be unconstrained and consequently we need to get
9020 the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
9021 The place where we need to do that is in subprograms having unconstrained
9022 array formal parameters. GNAT_NODE is the GNAT node conveying the source
9023 location for which the error should be signaled. */
9025 static tree
9026 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
9027 tree gnu_high, Node_Id gnat_node)
9029 tree gnu_expr_check;
9031 /* Checked expressions must be evaluated only once. */
9032 gnu_expr = gnat_protect_expr (gnu_expr);
9034 /* Must do this computation in the base type in case the expression's
9035 type is an unsigned subtypes. */
9036 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
9038 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
9039 the object we are handling. */
9040 gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
9041 gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
9043 return emit_check
9044 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9045 build_binary_op (LT_EXPR, boolean_type_node,
9046 gnu_expr_check,
9047 convert (TREE_TYPE (gnu_expr_check),
9048 gnu_low)),
9049 build_binary_op (GT_EXPR, boolean_type_node,
9050 gnu_expr_check,
9051 convert (TREE_TYPE (gnu_expr_check),
9052 gnu_high))),
9053 gnu_expr, CE_Index_Check_Failed, gnat_node);
9056 /* GNU_COND contains the condition corresponding to an index, overflow or
9057 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9058 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9059 REASON is the code that says why the exception is raised. GNAT_NODE is
9060 the node conveying the source location for which the error should be
9061 signaled.
9063 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9064 overwriting the setting inherited from the call statement, on the ground
9065 that the expression need not be evaluated just for the check. However
9066 that's incorrect because, in the GCC type system, its value is presumed
9067 to be valid so its comparison against the type bounds always yields true
9068 and, therefore, could be done without evaluating it; given that it can
9069 be a computation that overflows the bounds, the language may require the
9070 check to fail and thus the expression to be evaluated in this case. */
9072 static tree
9073 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
9075 tree gnu_call
9076 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
9077 return
9078 fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
9079 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
9080 convert (TREE_TYPE (gnu_expr), integer_zero_node)),
9081 gnu_expr);
9084 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
9085 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
9086 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
9087 float to integer conversion with truncation; otherwise round.
9088 GNAT_NODE is the GNAT node conveying the source location for which the
9089 error should be signaled. */
9091 static tree
9092 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
9093 bool rangep, bool truncatep, Node_Id gnat_node)
9095 tree gnu_type = get_unpadded_type (gnat_type);
9096 tree gnu_in_type = TREE_TYPE (gnu_expr);
9097 tree gnu_in_basetype = get_base_type (gnu_in_type);
9098 tree gnu_base_type = get_base_type (gnu_type);
9099 tree gnu_result = gnu_expr;
9101 /* If we are not doing any checks, the output is an integral type and the
9102 input is not a floating-point type, just do the conversion. This is
9103 required for packed array types and is simpler in all cases anyway. */
9104 if (!rangep
9105 && !overflowp
9106 && INTEGRAL_TYPE_P (gnu_base_type)
9107 && !FLOAT_TYPE_P (gnu_in_type))
9108 return convert (gnu_type, gnu_expr);
9110 /* First convert the expression to its base type. This
9111 will never generate code, but makes the tests below much simpler.
9112 But don't do this if converting from an integer type to an unconstrained
9113 array type since then we need to get the bounds from the original
9114 (unpacked) type. */
9115 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
9116 gnu_result = convert (gnu_in_basetype, gnu_result);
9118 /* If overflow checks are requested, we need to be sure the result will
9119 fit in the output base type. But don't do this if the input
9120 is integer and the output floating-point. */
9121 if (overflowp
9122 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
9124 /* Ensure GNU_EXPR only gets evaluated once. */
9125 tree gnu_input = gnat_protect_expr (gnu_result);
9126 tree gnu_cond = boolean_false_node;
9127 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
9128 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
9129 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
9130 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
9132 /* Convert the lower bounds to signed types, so we're sure we're
9133 comparing them properly. Likewise, convert the upper bounds
9134 to unsigned types. */
9135 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
9136 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
9138 if (INTEGRAL_TYPE_P (gnu_in_basetype)
9139 && !TYPE_UNSIGNED (gnu_in_basetype))
9140 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
9142 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
9143 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
9145 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
9146 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
9148 /* Check each bound separately and only if the result bound
9149 is tighter than the bound on the input type. Note that all the
9150 types are base types, so the bounds must be constant. Also,
9151 the comparison is done in the base type of the input, which
9152 always has the proper signedness. First check for input
9153 integer (which means output integer), output float (which means
9154 both float), or mixed, in which case we always compare.
9155 Note that we have to do the comparison which would *fail* in the
9156 case of an error since if it's an FP comparison and one of the
9157 values is a NaN or Inf, the comparison will fail. */
9158 if (INTEGRAL_TYPE_P (gnu_in_basetype)
9159 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
9160 : (FLOAT_TYPE_P (gnu_base_type)
9161 ? real_less (&TREE_REAL_CST (gnu_in_lb),
9162 &TREE_REAL_CST (gnu_out_lb))
9163 : 1))
9164 gnu_cond
9165 = invert_truthvalue
9166 (build_binary_op (GE_EXPR, boolean_type_node,
9167 gnu_input, convert (gnu_in_basetype,
9168 gnu_out_lb)));
9170 if (INTEGRAL_TYPE_P (gnu_in_basetype)
9171 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
9172 : (FLOAT_TYPE_P (gnu_base_type)
9173 ? real_less (&TREE_REAL_CST (gnu_out_ub),
9174 &TREE_REAL_CST (gnu_in_lb))
9175 : 1))
9176 gnu_cond
9177 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
9178 invert_truthvalue
9179 (build_binary_op (LE_EXPR, boolean_type_node,
9180 gnu_input,
9181 convert (gnu_in_basetype,
9182 gnu_out_ub))));
9184 if (!integer_zerop (gnu_cond))
9185 gnu_result = emit_check (gnu_cond, gnu_input,
9186 CE_Overflow_Check_Failed, gnat_node);
9189 /* Now convert to the result base type. If this is a non-truncating
9190 float-to-integer conversion, round. */
9191 if (INTEGRAL_TYPE_P (gnu_base_type)
9192 && FLOAT_TYPE_P (gnu_in_basetype)
9193 && !truncatep)
9195 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
9196 tree gnu_conv, gnu_zero, gnu_comp, calc_type;
9197 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
9198 const struct real_format *fmt;
9200 /* The following calculations depend on proper rounding to even
9201 of each arithmetic operation. In order to prevent excess
9202 precision from spoiling this property, use the widest hardware
9203 floating-point type if FP_ARITH_MAY_WIDEN is true. */
9204 calc_type
9205 = fp_arith_may_widen ? longest_float_type_node : gnu_in_basetype;
9207 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
9208 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
9209 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
9210 real_arithmetic (&pred_half, MINUS_EXPR, &dconsthalf,
9211 &half_minus_pred_half);
9212 gnu_pred_half = build_real (calc_type, pred_half);
9214 /* If the input is strictly negative, subtract this value
9215 and otherwise add it from the input. For 0.5, the result
9216 is exactly between 1.0 and the machine number preceding 1.0
9217 (for calc_type). Since the last bit of 1.0 is even, this 0.5
9218 will round to 1.0, while all other number with an absolute
9219 value less than 0.5 round to 0.0. For larger numbers exactly
9220 halfway between integers, rounding will always be correct as
9221 the true mathematical result will be closer to the higher
9222 integer compared to the lower one. So, this constant works
9223 for all floating-point numbers.
9225 The reason to use the same constant with subtract/add instead
9226 of a positive and negative constant is to allow the comparison
9227 to be scheduled in parallel with retrieval of the constant and
9228 conversion of the input to the calc_type (if necessary). */
9230 gnu_zero = convert (gnu_in_basetype, integer_zero_node);
9231 gnu_result = gnat_protect_expr (gnu_result);
9232 gnu_conv = convert (calc_type, gnu_result);
9233 gnu_comp
9234 = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
9235 gnu_add_pred_half
9236 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9237 gnu_subtract_pred_half
9238 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9239 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
9240 gnu_add_pred_half, gnu_subtract_pred_half);
9243 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9244 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
9245 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
9246 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
9247 else
9248 gnu_result = convert (gnu_base_type, gnu_result);
9250 /* Finally, do the range check if requested. Note that if the result type
9251 is a modular type, the range check is actually an overflow check. */
9252 if (rangep
9253 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9254 && TYPE_MODULAR_P (gnu_base_type) && overflowp))
9255 gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
9257 return convert (gnu_type, gnu_result);
9260 /* Return true if GNU_EXPR can be directly addressed. This is the case
9261 unless it is an expression involving computation or if it involves a
9262 reference to a bitfield or to an object not sufficiently aligned for
9263 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
9264 be directly addressed as an object of this type.
9266 *** Notes on addressability issues in the Ada compiler ***
9268 This predicate is necessary in order to bridge the gap between Gigi
9269 and the middle-end about addressability of GENERIC trees. A tree
9270 is said to be addressable if it can be directly addressed, i.e. if
9271 its address can be taken, is a multiple of the type's alignment on
9272 strict-alignment architectures and returns the first storage unit
9273 assigned to the object represented by the tree.
9275 In the C family of languages, everything is in practice addressable
9276 at the language level, except for bit-fields. This means that these
9277 compilers will take the address of any tree that doesn't represent
9278 a bit-field reference and expect the result to be the first storage
9279 unit assigned to the object. Even in cases where this will result
9280 in unaligned accesses at run time, nothing is supposed to be done
9281 and the program is considered as erroneous instead (see PR c/18287).
9283 The implicit assumptions made in the middle-end are in keeping with
9284 the C viewpoint described above:
9285 - the address of a bit-field reference is supposed to be never
9286 taken; the compiler (generally) will stop on such a construct,
9287 - any other tree is addressable if it is formally addressable,
9288 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
9290 In Ada, the viewpoint is the opposite one: nothing is addressable
9291 at the language level unless explicitly declared so. This means
9292 that the compiler will both make sure that the trees representing
9293 references to addressable ("aliased" in Ada parlance) objects are
9294 addressable and make no real attempts at ensuring that the trees
9295 representing references to non-addressable objects are addressable.
9297 In the first case, Ada is effectively equivalent to C and handing
9298 down the direct result of applying ADDR_EXPR to these trees to the
9299 middle-end works flawlessly. In the second case, Ada cannot afford
9300 to consider the program as erroneous if the address of trees that
9301 are not addressable is requested for technical reasons, unlike C;
9302 as a consequence, the Ada compiler must arrange for either making
9303 sure that this address is not requested in the middle-end or for
9304 compensating by inserting temporaries if it is requested in Gigi.
9306 The first goal can be achieved because the middle-end should not
9307 request the address of non-addressable trees on its own; the only
9308 exception is for the invocation of low-level block operations like
9309 memcpy, for which the addressability requirements are lower since
9310 the type's alignment can be disregarded. In practice, this means
9311 that Gigi must make sure that such operations cannot be applied to
9312 non-BLKmode bit-fields.
9314 The second goal is achieved by means of the addressable_p predicate,
9315 which computes whether a temporary must be inserted by Gigi when the
9316 address of a tree is requested; if so, the address of the temporary
9317 will be used in lieu of that of the original tree and some glue code
9318 generated to connect everything together. */
9320 static bool
9321 addressable_p (tree gnu_expr, tree gnu_type)
9323 /* For an integral type, the size of the actual type of the object may not
9324 be greater than that of the expected type, otherwise an indirect access
9325 in the latter type wouldn't correctly set all the bits of the object. */
9326 if (gnu_type
9327 && INTEGRAL_TYPE_P (gnu_type)
9328 && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
9329 return false;
9331 /* The size of the actual type of the object may not be smaller than that
9332 of the expected type, otherwise an indirect access in the latter type
9333 would be larger than the object. But only record types need to be
9334 considered in practice for this case. */
9335 if (gnu_type
9336 && TREE_CODE (gnu_type) == RECORD_TYPE
9337 && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
9338 return false;
9340 switch (TREE_CODE (gnu_expr))
9342 case VAR_DECL:
9343 case PARM_DECL:
9344 case FUNCTION_DECL:
9345 case RESULT_DECL:
9346 /* All DECLs are addressable: if they are in a register, we can force
9347 them to memory. */
9348 return true;
9350 case UNCONSTRAINED_ARRAY_REF:
9351 case INDIRECT_REF:
9352 /* Taking the address of a dereference yields the original pointer. */
9353 return true;
9355 case STRING_CST:
9356 case INTEGER_CST:
9357 /* Taking the address yields a pointer to the constant pool. */
9358 return true;
9360 case CONSTRUCTOR:
9361 /* Taking the address of a static constructor yields a pointer to the
9362 tree constant pool. */
9363 return TREE_STATIC (gnu_expr) ? true : false;
9365 case NULL_EXPR:
9366 case SAVE_EXPR:
9367 case CALL_EXPR:
9368 case PLUS_EXPR:
9369 case MINUS_EXPR:
9370 case BIT_IOR_EXPR:
9371 case BIT_XOR_EXPR:
9372 case BIT_AND_EXPR:
9373 case BIT_NOT_EXPR:
9374 /* All rvalues are deemed addressable since taking their address will
9375 force a temporary to be created by the middle-end. */
9376 return true;
9378 case COMPOUND_EXPR:
9379 /* The address of a compound expression is that of its 2nd operand. */
9380 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
9382 case COND_EXPR:
9383 /* We accept &COND_EXPR as soon as both operands are addressable and
9384 expect the outcome to be the address of the selected operand. */
9385 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
9386 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
9388 case COMPONENT_REF:
9389 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
9390 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
9391 the field is sufficiently aligned, in case it is subject
9392 to a pragma Component_Alignment. But we don't need to
9393 check the alignment of the containing record, as it is
9394 guaranteed to be not smaller than that of its most
9395 aligned field that is not a bit-field. */
9396 && (!STRICT_ALIGNMENT
9397 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
9398 >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
9399 /* The field of a padding record is always addressable. */
9400 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
9401 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9403 case ARRAY_REF: case ARRAY_RANGE_REF:
9404 case REALPART_EXPR: case IMAGPART_EXPR:
9405 case NOP_EXPR:
9406 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
9408 case CONVERT_EXPR:
9409 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
9410 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9412 case VIEW_CONVERT_EXPR:
9414 /* This is addressable if we can avoid a copy. */
9415 tree type = TREE_TYPE (gnu_expr);
9416 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
9417 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
9418 && (!STRICT_ALIGNMENT
9419 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
9420 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
9421 || ((TYPE_MODE (type) == BLKmode
9422 || TYPE_MODE (inner_type) == BLKmode)
9423 && (!STRICT_ALIGNMENT
9424 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
9425 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
9426 || TYPE_ALIGN_OK (type)
9427 || TYPE_ALIGN_OK (inner_type))))
9428 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9431 default:
9432 return false;
9436 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
9437 a separate Freeze node exists, delay the bulk of the processing. Otherwise
9438 make a GCC type for GNAT_ENTITY and set up the correspondence. */
9440 void
9441 process_type (Entity_Id gnat_entity)
9443 tree gnu_old
9444 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
9445 tree gnu_new;
9447 /* If we are to delay elaboration of this type, just do any
9448 elaborations needed for expressions within the declaration and
9449 make a dummy type entry for this node and its Full_View (if
9450 any) in case something points to it. Don't do this if it
9451 has already been done (the only way that can happen is if
9452 the private completion is also delayed). */
9453 if (Present (Freeze_Node (gnat_entity))
9454 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
9455 && Present (Full_View (gnat_entity))
9456 && Present (Freeze_Node (Full_View (gnat_entity)))
9457 && !present_gnu_tree (Full_View (gnat_entity))))
9459 elaborate_entity (gnat_entity);
9461 if (!gnu_old)
9463 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
9464 save_gnu_tree (gnat_entity, gnu_decl, false);
9465 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
9466 && Present (Full_View (gnat_entity)))
9468 if (Has_Completion_In_Body (gnat_entity))
9469 DECL_TAFT_TYPE_P (gnu_decl) = 1;
9470 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
9474 return;
9477 /* If we saved away a dummy type for this node it means that this
9478 made the type that corresponds to the full type of an incomplete
9479 type. Clear that type for now and then update the type in the
9480 pointers. */
9481 if (gnu_old)
9483 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
9484 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
9486 save_gnu_tree (gnat_entity, NULL_TREE, false);
9489 /* Now fully elaborate the type. */
9490 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
9491 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
9493 /* If we have an old type and we've made pointers to this type, update those
9494 pointers. If this is a Taft amendment type in the main unit, we need to
9495 mark the type as used since other units referencing it don't see the full
9496 declaration and, therefore, cannot mark it as used themselves. */
9497 if (gnu_old)
9499 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
9500 TREE_TYPE (gnu_new));
9501 if (DECL_TAFT_TYPE_P (gnu_old))
9502 used_types_insert (TREE_TYPE (gnu_new));
9505 /* If this is a record type corresponding to a task or protected type
9506 that is a completion of an incomplete type, perform a similar update
9507 on the type. ??? Including protected types here is a guess. */
9508 if (IN (Ekind (gnat_entity), Record_Kind)
9509 && Is_Concurrent_Record_Type (gnat_entity)
9510 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
9512 tree gnu_task_old
9513 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
9515 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
9516 NULL_TREE, false);
9517 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
9518 gnu_new, false);
9520 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
9521 TREE_TYPE (gnu_new));
9525 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
9526 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
9527 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
9529 static tree
9530 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
9532 tree gnu_list = NULL_TREE, gnu_result;
9534 /* We test for GNU_FIELD being empty in the case where a variant
9535 was the last thing since we don't take things off GNAT_ASSOC in
9536 that case. We check GNAT_ASSOC in case we have a variant, but it
9537 has no fields. */
9539 for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
9541 Node_Id gnat_field = First (Choices (gnat_assoc));
9542 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
9543 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
9545 /* The expander is supposed to put a single component selector name
9546 in every record component association. */
9547 gcc_assert (No (Next (gnat_field)));
9549 /* Ignore fields that have Corresponding_Discriminants since we'll
9550 be setting that field in the parent. */
9551 if (Present (Corresponding_Discriminant (Entity (gnat_field)))
9552 && Is_Tagged_Type (Scope (Entity (gnat_field))))
9553 continue;
9555 /* Also ignore discriminants of Unchecked_Unions. */
9556 if (Is_Unchecked_Union (gnat_entity)
9557 && Ekind (Entity (gnat_field)) == E_Discriminant)
9558 continue;
9560 /* Before assigning a value in an aggregate make sure range checks
9561 are done if required. Then convert to the type of the field. */
9562 if (Do_Range_Check (Expression (gnat_assoc)))
9563 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
9565 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
9567 /* Add the field and expression to the list. */
9568 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
9571 gnu_result = extract_values (gnu_list, gnu_type);
9573 if (flag_checking)
9575 /* Verify that every entry in GNU_LIST was used. */
9576 for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
9577 gcc_assert (TREE_ADDRESSABLE (gnu_list));
9580 return gnu_result;
9583 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
9584 the first element of an array aggregate. It may itself be an aggregate.
9585 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
9586 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
9587 for range checking. */
9589 static tree
9590 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
9591 Entity_Id gnat_component_type)
9593 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
9594 tree gnu_expr;
9595 vec<constructor_elt, va_gc> *gnu_expr_vec = NULL;
9597 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
9599 /* If the expression is itself an array aggregate then first build the
9600 innermost constructor if it is part of our array (multi-dimensional
9601 case). */
9602 if (Nkind (gnat_expr) == N_Aggregate
9603 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
9604 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
9605 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
9606 TREE_TYPE (gnu_array_type),
9607 gnat_component_type);
9608 else
9610 gnu_expr = gnat_to_gnu (gnat_expr);
9612 /* Before assigning the element to the array, make sure it is
9613 in range. */
9614 if (Do_Range_Check (gnat_expr))
9615 gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
9618 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
9619 convert (TREE_TYPE (gnu_array_type), gnu_expr));
9621 gnu_index = int_const_binop (PLUS_EXPR, gnu_index,
9622 convert (TREE_TYPE (gnu_index),
9623 integer_one_node));
9626 return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
9629 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
9630 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
9631 associations that are from RECORD_TYPE. If we see an internal record, make
9632 a recursive call to fill it in as well. */
9634 static tree
9635 extract_values (tree values, tree record_type)
9637 tree field, tem;
9638 vec<constructor_elt, va_gc> *v = NULL;
9640 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
9642 tree value = 0;
9644 /* _Parent is an internal field, but may have values in the aggregate,
9645 so check for values first. */
9646 if ((tem = purpose_member (field, values)))
9648 value = TREE_VALUE (tem);
9649 TREE_ADDRESSABLE (tem) = 1;
9652 else if (DECL_INTERNAL_P (field))
9654 value = extract_values (values, TREE_TYPE (field));
9655 if (TREE_CODE (value) == CONSTRUCTOR
9656 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value)))
9657 value = 0;
9659 else
9660 /* If we have a record subtype, the names will match, but not the
9661 actual FIELD_DECLs. */
9662 for (tem = values; tem; tem = TREE_CHAIN (tem))
9663 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
9665 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
9666 TREE_ADDRESSABLE (tem) = 1;
9669 if (!value)
9670 continue;
9672 CONSTRUCTOR_APPEND_ELT (v, field, value);
9675 return gnat_build_constructor (record_type, v);
9678 /* Process a N_Validate_Unchecked_Conversion node. */
9680 static void
9681 validate_unchecked_conversion (Node_Id gnat_node)
9683 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
9684 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
9686 /* If the target is a pointer type, see if we are either converting from a
9687 non-pointer or from a pointer to a type with a different alias set and
9688 warn if so, unless the pointer has been marked to alias everything. */
9689 if (POINTER_TYPE_P (gnu_target_type)
9690 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
9692 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
9693 ? TREE_TYPE (gnu_source_type)
9694 : NULL_TREE;
9695 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
9696 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
9698 if (target_alias_set != 0
9699 && (!POINTER_TYPE_P (gnu_source_type)
9700 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
9701 target_alias_set)))
9703 post_error_ne ("?possible aliasing problem for type&",
9704 gnat_node, Target_Type (gnat_node));
9705 post_error ("\\?use -fno-strict-aliasing switch for references",
9706 gnat_node);
9707 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
9708 gnat_node, Target_Type (gnat_node));
9712 /* Likewise if the target is a fat pointer type, but we have no mechanism to
9713 mitigate the problem in this case, so we unconditionally warn. */
9714 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
9716 tree gnu_source_desig_type
9717 = TYPE_IS_FAT_POINTER_P (gnu_source_type)
9718 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
9719 : NULL_TREE;
9720 tree gnu_target_desig_type
9721 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
9722 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
9724 if (target_alias_set != 0
9725 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
9726 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
9727 target_alias_set)))
9729 post_error_ne ("?possible aliasing problem for type&",
9730 gnat_node, Target_Type (gnat_node));
9731 post_error ("\\?use -fno-strict-aliasing switch for references",
9732 gnat_node);
9737 /* EXP is to be treated as an array or record. Handle the cases when it is
9738 an access object and perform the required dereferences. */
9740 static tree
9741 maybe_implicit_deref (tree exp)
9743 /* If the type is a pointer, dereference it. */
9744 if (POINTER_TYPE_P (TREE_TYPE (exp))
9745 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
9746 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
9748 /* If we got a padded type, remove it too. */
9749 if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
9750 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
9752 return exp;
9755 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
9756 location and false if it doesn't. If CLEAR_COLUMN is true, set the column
9757 information to 0. */
9759 bool
9760 Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column)
9762 if (Sloc == No_Location)
9763 return false;
9765 if (Sloc <= Standard_Location)
9767 *locus = BUILTINS_LOCATION;
9768 return false;
9771 Source_File_Index file = Get_Source_File_Index (Sloc);
9772 Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
9773 Column_Number column = (clear_column ? 0 : Get_Column_Number (Sloc));
9774 line_map_ordinary *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
9776 /* We can have zero if pragma Source_Reference is in effect. */
9777 if (line < 1)
9778 line = 1;
9780 /* Translate the location. */
9781 *locus = linemap_position_for_line_and_column (line_table, map,
9782 line, column);
9784 return true;
9787 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
9788 don't do anything if it doesn't correspond to a source location. And,
9789 if CLEAR_COLUMN is true, set the column information to 0. */
9791 static void
9792 set_expr_location_from_node (tree node, Node_Id gnat_node, bool clear_column)
9794 location_t locus;
9796 if (!Sloc_to_locus (Sloc (gnat_node), &locus, clear_column))
9797 return;
9799 SET_EXPR_LOCATION (node, locus);
9802 /* More elaborate version of set_expr_location_from_node to be used in more
9803 general contexts, for example the result of the translation of a generic
9804 GNAT node. */
9806 static void
9807 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
9809 /* Set the location information on the node if it is a real expression.
9810 References can be reused for multiple GNAT nodes and they would get
9811 the location information of their last use. Also make sure not to
9812 overwrite an existing location as it is probably more precise. */
9814 switch (TREE_CODE (node))
9816 CASE_CONVERT:
9817 case NON_LVALUE_EXPR:
9818 case SAVE_EXPR:
9819 break;
9821 case COMPOUND_EXPR:
9822 if (EXPR_P (TREE_OPERAND (node, 1)))
9823 set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
9825 /* ... fall through ... */
9827 default:
9828 if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
9830 set_expr_location_from_node (node, gnat_node);
9831 set_end_locus_from_node (node, gnat_node);
9833 break;
9837 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
9838 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
9839 most sense. Return true if a sensible assignment was performed. */
9841 static bool
9842 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
9844 Node_Id gnat_end_label;
9845 location_t end_locus;
9847 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
9848 end_locus when there is one. We consider only GNAT nodes with a possible
9849 End_Label attached. If the End_Label actually was unassigned, fallback
9850 on the original node. We'd better assign an explicit sloc associated with
9851 the outer construct in any case. */
9853 switch (Nkind (gnat_node))
9855 case N_Package_Body:
9856 case N_Subprogram_Body:
9857 case N_Block_Statement:
9858 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
9859 break;
9861 case N_Package_Declaration:
9862 gnat_end_label = End_Label (Specification (gnat_node));
9863 break;
9865 default:
9866 return false;
9869 if (Present (gnat_end_label))
9870 gnat_node = gnat_end_label;
9872 /* Some expanded subprograms have neither an End_Label nor a Sloc
9873 attached. Notify that to callers. For a block statement with no
9874 End_Label, clear column information, so that the tree for a
9875 transient block does not receive the sloc of a source condition. */
9876 if (!Sloc_to_locus (Sloc (gnat_node), &end_locus,
9877 No (gnat_end_label)
9878 && (Nkind (gnat_node) == N_Block_Statement)))
9879 return false;
9881 switch (TREE_CODE (gnu_node))
9883 case BIND_EXPR:
9884 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
9885 return true;
9887 case FUNCTION_DECL:
9888 DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
9889 return true;
9891 default:
9892 return false;
9896 /* Return a colon-separated list of encodings contained in encoded Ada
9897 name. */
9899 static const char *
9900 extract_encoding (const char *name)
9902 char *encoding = (char *) ggc_alloc_atomic (strlen (name));
9903 get_encoding (name, encoding);
9904 return encoding;
9907 /* Extract the Ada name from an encoded name. */
9909 static const char *
9910 decode_name (const char *name)
9912 char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
9913 __gnat_decode (name, decoded, 0);
9914 return decoded;
9917 /* Post an error message. MSG is the error message, properly annotated.
9918 NODE is the node at which to post the error and the node to use for the
9919 '&' substitution. */
9921 void
9922 post_error (const char *msg, Node_Id node)
9924 String_Template temp;
9925 String_Pointer sp;
9927 if (No (node))
9928 return;
9930 temp.Low_Bound = 1;
9931 temp.High_Bound = strlen (msg);
9932 sp.Bounds = &temp;
9933 sp.Array = msg;
9934 Error_Msg_N (sp, node);
9937 /* Similar to post_error, but NODE is the node at which to post the error and
9938 ENT is the node to use for the '&' substitution. */
9940 void
9941 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
9943 String_Template temp;
9944 String_Pointer sp;
9946 if (No (node))
9947 return;
9949 temp.Low_Bound = 1;
9950 temp.High_Bound = strlen (msg);
9951 sp.Bounds = &temp;
9952 sp.Array = msg;
9953 Error_Msg_NE (sp, node, ent);
9956 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
9958 void
9959 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
9961 Error_Msg_Uint_1 = UI_From_Int (num);
9962 post_error_ne (msg, node, ent);
9965 /* Similar to post_error_ne, but T is a GCC tree representing the number to
9966 write. If T represents a constant, the text inside curly brackets in
9967 MSG will be output (presumably including a '^'). Otherwise it will not
9968 be output and the text inside square brackets will be output instead. */
9970 void
9971 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
9973 char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
9974 char start_yes, end_yes, start_no, end_no;
9975 const char *p;
9976 char *q;
9978 if (TREE_CODE (t) == INTEGER_CST)
9980 Error_Msg_Uint_1 = UI_From_gnu (t);
9981 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
9983 else
9984 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
9986 for (p = msg, q = new_msg; *p; p++)
9988 if (*p == start_yes)
9989 for (p++; *p != end_yes; p++)
9990 *q++ = *p;
9991 else if (*p == start_no)
9992 for (p++; *p != end_no; p++)
9994 else
9995 *q++ = *p;
9998 *q = 0;
10000 post_error_ne (new_msg, node, ent);
10003 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
10005 void
10006 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
10007 int num)
10009 Error_Msg_Uint_2 = UI_From_Int (num);
10010 post_error_ne_tree (msg, node, ent, t);
10013 /* Initialize the table that maps GNAT codes to GCC codes for simple
10014 binary and unary operations. */
10016 static void
10017 init_code_table (void)
10019 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
10020 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
10022 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
10023 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
10024 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
10025 gnu_codes[N_Op_Eq] = EQ_EXPR;
10026 gnu_codes[N_Op_Ne] = NE_EXPR;
10027 gnu_codes[N_Op_Lt] = LT_EXPR;
10028 gnu_codes[N_Op_Le] = LE_EXPR;
10029 gnu_codes[N_Op_Gt] = GT_EXPR;
10030 gnu_codes[N_Op_Ge] = GE_EXPR;
10031 gnu_codes[N_Op_Add] = PLUS_EXPR;
10032 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
10033 gnu_codes[N_Op_Multiply] = MULT_EXPR;
10034 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
10035 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
10036 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
10037 gnu_codes[N_Op_Abs] = ABS_EXPR;
10038 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
10039 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
10040 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
10041 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
10042 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
10043 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
10046 /* Return a label to branch to for the exception type in KIND or NULL_TREE
10047 if none. */
10049 tree
10050 get_exception_label (char kind)
10052 if (kind == N_Raise_Constraint_Error)
10053 return gnu_constraint_error_label_stack->last ();
10054 else if (kind == N_Raise_Storage_Error)
10055 return gnu_storage_error_label_stack->last ();
10056 else if (kind == N_Raise_Program_Error)
10057 return gnu_program_error_label_stack->last ();
10058 else
10059 return NULL_TREE;
10062 /* Return the decl for the current elaboration procedure. */
10064 tree
10065 get_elaboration_procedure (void)
10067 return gnu_elab_proc_stack->last ();
10070 #include "gt-ada-trans.h"