ada: Simplify the implementation of storage models
[official-gcc.git] / gcc / ada / gcc-interface / trans.cc
blob92c8dc33af821333dd4c8db0365bd0b4c661ee0d
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2023, 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 "debug.h"
45 #include "libfuncs.h" /* For set_stack_check_libfunc. */
46 #include "tree-iterator.h"
47 #include "gimplify.h"
48 #include "opts.h"
49 #include "common/common-target.h"
50 #include "gomp-constants.h"
51 #include "stringpool.h"
52 #include "attribs.h"
53 #include "tree-nested.h"
55 #include "ada.h"
56 #include "adadecode.h"
57 #include "types.h"
58 #include "atree.h"
59 #include "namet.h"
60 #include "nlists.h"
61 #include "snames.h"
62 #include "stringt.h"
63 #include "uintp.h"
64 #include "urealp.h"
65 #include "fe.h"
66 #include "sinfo.h"
67 #include "einfo.h"
68 #include "gadaint.h"
69 #include "ada-tree.h"
70 #include "gigi.h"
72 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
73 for fear of running out of stack space. If we need more, we use xmalloc
74 instead. */
75 #define ALLOCA_THRESHOLD 1000
77 /* Pointers to front-end tables accessed through macros. */
78 Node_Header *Node_Offsets_Ptr;
79 any_slot *Slots_Ptr;
80 Node_Id *Next_Node_Ptr;
81 Node_Id *Prev_Node_Ptr;
82 struct Elist_Header *Elists_Ptr;
83 struct Elmt_Item *Elmts_Ptr;
84 struct String_Entry *Strings_Ptr;
85 Char_Code *String_Chars_Ptr;
86 struct List_Header *List_Headers_Ptr;
88 /* Highest number in the front-end node table. */
89 int max_gnat_nodes;
91 /* True when gigi is being called on an analyzed but unexpanded
92 tree, and the only purpose of the call is to properly annotate
93 types with representation information. */
94 bool type_annotate_only;
96 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
97 static vec<Node_Id> gnat_validate_uc_list;
99 /* List of expressions of pragma Compile_Time_{Error|Warning} in the unit. */
100 static vec<Node_Id> gnat_compile_time_expr_list;
102 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
103 of unconstrained array IN parameters to avoid emitting a great deal of
104 redundant instructions to recompute them each time. */
105 struct GTY (()) parm_attr_d {
106 int id; /* GTY doesn't like Entity_Id. */
107 int dim;
108 tree first;
109 tree last;
110 tree length;
113 typedef struct parm_attr_d *parm_attr;
115 /* Structure used to record information for a function. */
116 struct GTY(()) language_function {
117 vec<parm_attr, va_gc> *parm_attr_cache;
118 bitmap named_ret_val;
119 vec<tree, va_gc> *other_ret_val;
120 int gnat_ret;
123 #define f_parm_attr_cache \
124 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
126 #define f_named_ret_val \
127 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
129 #define f_other_ret_val \
130 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
132 #define f_gnat_ret \
133 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
135 /* A structure used to gather together information about a statement group.
136 We use this to gather related statements, for example the "then" part
137 of a IF. In the case where it represents a lexical scope, we may also
138 have a BLOCK node corresponding to it and/or cleanups. */
140 struct GTY((chain_next ("%h.previous"))) stmt_group {
141 struct stmt_group *previous; /* Previous code group. */
142 tree stmt_list; /* List of statements for this code group. */
143 tree block; /* BLOCK for this code group, if any. */
144 tree cleanups; /* Cleanups for this code group, if any. */
147 static GTY(()) struct stmt_group *current_stmt_group;
149 /* List of unused struct stmt_group nodes. */
150 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
152 /* A structure used to record information on elaboration procedures
153 we've made and need to process.
155 ??? gnat_node should be Node_Id, but gengtype gets confused. */
157 struct GTY((chain_next ("%h.next"))) elab_info {
158 struct elab_info *next; /* Pointer to next in chain. */
159 tree elab_proc; /* Elaboration procedure. */
160 int gnat_node; /* The N_Compilation_Unit. */
163 static GTY(()) struct elab_info *elab_info_list;
165 /* Stack of exception pointer variables. Each entry is the VAR_DECL
166 that stores the address of the raised exception. Nonzero means we
167 are in an exception handler. Not used in the zero-cost case. */
168 static GTY(()) vec<tree, va_gc> *gnu_except_ptr_stack;
170 /* In ZCX case, current exception pointer. Used to re-raise it. */
171 static GTY(()) tree gnu_incoming_exc_ptr;
173 /* Stack for storing the current elaboration procedure decl. */
174 static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack;
176 /* Stack of labels to be used as a goto target instead of a return in
177 some functions. See processing for N_Subprogram_Body. */
178 static GTY(()) vec<tree, va_gc> *gnu_return_label_stack;
180 /* Stack of variable for the return value of a function with copy-in/copy-out
181 parameters. See processing for N_Subprogram_Body. */
182 static GTY(()) vec<tree, va_gc> *gnu_return_var_stack;
184 /* Structure used to record information for a range check. */
185 struct GTY(()) range_check_info_d {
186 tree low_bound;
187 tree high_bound;
188 tree disp;
189 bool neg_p;
190 tree type;
191 tree invariant_cond;
192 tree inserted_cond;
195 typedef struct range_check_info_d *range_check_info;
197 /* Structure used to record information for a loop. */
198 struct GTY(()) loop_info_d {
199 tree fndecl;
200 tree stmt;
201 tree loop_var;
202 tree low_bound;
203 tree high_bound;
204 tree omp_loop_clauses;
205 tree omp_construct_clauses;
206 enum tree_code omp_code;
207 vec<range_check_info, va_gc> *checks;
208 vec<tree, va_gc> *invariants;
211 typedef struct loop_info_d *loop_info;
213 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
214 static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
216 /* The stacks for N_{Push,Pop}_*_Label. */
217 static vec<Entity_Id> gnu_constraint_error_label_stack;
218 static vec<Entity_Id> gnu_storage_error_label_stack;
219 static vec<Entity_Id> gnu_program_error_label_stack;
221 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
222 static enum tree_code gnu_codes[Number_Node_Kinds];
224 static void init_code_table (void);
225 static tree get_elaboration_procedure (void);
226 static void Compilation_Unit_to_gnu (Node_Id);
227 static bool empty_stmt_list_p (tree);
228 static void record_code_position (Node_Id);
229 static void insert_code_for (Node_Id);
230 static void add_cleanup (tree, Node_Id);
231 static void add_stmt_list (List_Id);
232 static tree build_stmt_group (List_Id, bool);
233 static inline bool stmt_group_may_fallthru (void);
234 static enum gimplify_status gnat_gimplify_stmt (tree *);
235 static void elaborate_all_entities (Node_Id);
236 static void process_freeze_entity (Node_Id);
237 static void process_decls (List_Id, List_Id, bool, bool);
238 static tree emit_check (tree, tree, int, Node_Id);
239 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
240 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
241 static tree convert_with_check (Entity_Id, tree, bool, bool, Node_Id);
242 static bool addressable_p (tree, tree);
243 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
244 static tree pos_to_constructor (Node_Id, tree);
245 static void validate_unchecked_conversion (Node_Id);
246 static void set_expr_location_from_node (tree, Node_Id, bool = false);
247 static void set_gnu_expr_location_from_node (tree, Node_Id);
248 static bool set_end_locus_from_node (tree, Node_Id);
249 static int lvalue_required_p (Node_Id, tree, bool, bool);
250 static tree build_raise_check (int, enum exception_info_kind);
251 static tree create_init_temporary (const char *, tree, tree *, Node_Id);
252 static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk);
254 /* This makes gigi's file_info_ptr visible in this translation unit,
255 so that Sloc_to_locus can look it up when deciding whether to map
256 decls to instances. */
258 static struct File_Info_Type *file_map;
260 /* Return the string of the identifier allocated for the file name Id. */
262 static const char*
263 File_Name_to_gnu (Name_Id Id)
265 /* __gnat_to_canonical_file_spec translates file names from pragmas
266 Source_Reference that contain host style syntax not understood by GDB. */
267 const char *name = __gnat_to_canonical_file_spec (Get_Name_String (Id));
269 /* Use the identifier table to make a permanent copy of the file name as
270 the name table gets reallocated after Gigi returns but before all the
271 debugging information is output. */
272 return IDENTIFIER_POINTER (get_identifier (name));
275 /* This is the main program of the back-end. It sets up all the table
276 structures and then generates code. */
278 void
279 gigi (Node_Id gnat_root,
280 int max_gnat_node,
281 int number_name ATTRIBUTE_UNUSED,
282 Node_Header *node_offsets_ptr,
283 any_slot *slots_ptr,
284 Node_Id *next_node_ptr,
285 Node_Id *prev_node_ptr,
286 struct Elist_Header *elists_ptr,
287 struct Elmt_Item *elmts_ptr,
288 struct String_Entry *strings_ptr,
289 Char_Code *string_chars_ptr,
290 struct List_Header *list_headers_ptr,
291 Nat number_file,
292 struct File_Info_Type *file_info_ptr,
293 Entity_Id standard_address,
294 Entity_Id standard_boolean,
295 Entity_Id standard_character,
296 Entity_Id standard_exception_type,
297 Entity_Id standard_integer,
298 Entity_Id standard_long_long_float,
299 Int gigi_operating_mode)
301 Node_Id gnat_iter;
302 Entity_Id gnat_literal;
303 tree t, ftype, int64_type;
304 struct elab_info *info;
305 int i;
307 max_gnat_nodes = max_gnat_node;
309 Node_Offsets_Ptr = node_offsets_ptr;
310 Slots_Ptr = slots_ptr;
311 Next_Node_Ptr = next_node_ptr;
312 Prev_Node_Ptr = prev_node_ptr;
313 Elists_Ptr = elists_ptr;
314 Elmts_Ptr = elmts_ptr;
315 Strings_Ptr = strings_ptr;
316 String_Chars_Ptr = string_chars_ptr;
317 List_Headers_Ptr = list_headers_ptr;
319 type_annotate_only = (gigi_operating_mode == 1);
321 if (Generate_SCO_Instance_Table != 0)
323 file_map = file_info_ptr;
324 maybe_create_decl_to_instance_map (number_file);
327 for (i = 0; i < number_file; i++)
329 /* We rely on the order isomorphism between files and line maps. */
330 if ((int) LINEMAPS_ORDINARY_USED (line_table) != i)
332 gcc_assert (i > 0);
333 error ("%s contains too many lines",
334 File_Name_to_gnu (file_info_ptr[i - 1].File_Name));
337 /* We create the line map for a source file at once, with a fixed number
338 of columns chosen to avoid jumping over the next power of 2. */
339 linemap_add (line_table, LC_ENTER, 0,
340 File_Name_to_gnu (file_info_ptr[i].File_Name), 1);
341 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
342 linemap_position_for_column (line_table, 252 - 1);
343 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
346 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
348 /* Declare the name of the compilation unit as the first global
349 name in order to make the middle-end fully deterministic. */
350 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
351 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
353 /* Initialize ourselves. */
354 init_code_table ();
355 init_gnat_decl ();
356 init_gnat_utils ();
358 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
359 errors. */
360 if (type_annotate_only)
362 TYPE_SIZE (void_type_node) = bitsize_zero_node;
363 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
366 /* Enable GNAT stack checking method if needed */
367 if (!Stack_Check_Probes_On_Target)
369 set_stack_check_libfunc ("__gnat_stack_check");
370 if (flag_stack_check != NO_STACK_CHECK)
371 Check_Restriction_No_Dependence_On_System (Name_Stack_Checking,
372 gnat_root);
375 /* Retrieve alignment settings. */
376 double_float_alignment = get_target_double_float_alignment ();
377 double_scalar_alignment = get_target_double_scalar_alignment ();
379 /* Record the builtin types. */
380 record_builtin_type ("address", pointer_sized_int_node, false);
381 record_builtin_type ("integer", integer_type_node, false);
382 record_builtin_type ("character", char_type_node, false);
383 record_builtin_type ("boolean", boolean_type_node, false);
384 record_builtin_type ("void", void_type_node, false);
386 /* Save the type we made for address as the type for Standard.Address. */
387 save_gnu_tree (Base_Type (standard_address),
388 TYPE_NAME (pointer_sized_int_node),
389 false);
391 /* Likewise for integer as the type for Standard.Integer. */
392 save_gnu_tree (Base_Type (standard_integer),
393 TYPE_NAME (integer_type_node),
394 false);
396 /* Likewise for character as the type for Standard.Character. */
397 finish_character_type (char_type_node);
398 save_gnu_tree (Base_Type (standard_character),
399 TYPE_NAME (char_type_node),
400 false);
402 /* Likewise for boolean as the type for Standard.Boolean. */
403 save_gnu_tree (Base_Type (standard_boolean),
404 TYPE_NAME (boolean_type_node),
405 false);
406 gnat_literal = First_Literal (Base_Type (standard_boolean));
407 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
408 gcc_assert (t == boolean_false_node);
409 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
410 boolean_type_node, t, true, false, false, false, false,
411 true, false, NULL, gnat_literal);
412 save_gnu_tree (gnat_literal, t, false);
413 gnat_literal = Next_Literal (gnat_literal);
414 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
415 gcc_assert (t == boolean_true_node);
416 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
417 boolean_type_node, t, true, false, false, false, false,
418 true, false, NULL, gnat_literal);
419 save_gnu_tree (gnat_literal, t, false);
421 /* Declare the building blocks of function nodes. */
422 void_ftype = build_function_type_list (void_type_node, NULL_TREE);
423 ptr_void_ftype = build_pointer_type (void_ftype);
425 /* Now declare run-time functions. */
426 malloc_decl
427 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
428 build_function_type_list (ptr_type_node, sizetype,
429 NULL_TREE),
430 NULL_TREE, is_default, true, true, true, false,
431 false, NULL, Empty);
432 DECL_IS_MALLOC (malloc_decl) = 1;
434 free_decl
435 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
436 build_function_type_list (void_type_node,
437 ptr_type_node, NULL_TREE),
438 NULL_TREE, is_default, true, true, true, false,
439 false, NULL, Empty);
441 realloc_decl
442 = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE,
443 build_function_type_list (ptr_type_node,
444 ptr_type_node, sizetype,
445 NULL_TREE),
446 NULL_TREE, is_default, true, true, true, false,
447 false, NULL, Empty);
449 /* This is used for 64-bit multiplication with overflow checking. */
450 int64_type = gnat_type_for_size (64, 0);
451 mulv64_decl
452 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
453 build_function_type_list (int64_type, int64_type,
454 int64_type, NULL_TREE),
455 NULL_TREE, is_default, true, true, true, false,
456 false, NULL, Empty);
458 if (Enable_128bit_Types)
460 tree int128_type = gnat_type_for_size (128, 0);
461 mulv128_decl
462 = create_subprog_decl (get_identifier ("__gnat_mulv128"), NULL_TREE,
463 build_function_type_list (int128_type,
464 int128_type,
465 int128_type,
466 NULL_TREE),
467 NULL_TREE, is_default, true, true, true, false,
468 false, NULL, Empty);
471 /* Name of the _Parent field in tagged record types. */
472 parent_name_id = get_identifier (Get_Name_String (Name_uParent));
474 /* Name of the Not_Handled_By_Others field in exception record types. */
475 not_handled_by_others_name_id = get_identifier ("not_handled_by_others");
477 /* Make the types and functions used for exception processing. */
478 except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type));
480 set_exception_parameter_decl
481 = create_subprog_decl
482 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
483 build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
484 NULL_TREE),
485 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
487 /* Hooks to call when entering/leaving an exception handler. */
488 ftype = build_function_type_list (ptr_type_node,
489 ptr_type_node, NULL_TREE);
490 begin_handler_decl
491 = create_subprog_decl (get_identifier ("__gnat_begin_handler_v1"),
492 NULL_TREE, ftype, NULL_TREE,
493 is_default, true, true, true, false, false, NULL,
494 Empty);
495 /* __gnat_begin_handler_v1 is not a dummy procedure, but we arrange
496 for it not to throw. */
497 TREE_NOTHROW (begin_handler_decl) = 1;
499 ftype = build_function_type_list (ptr_type_node,
500 ptr_type_node, ptr_type_node,
501 ptr_type_node, NULL_TREE);
502 end_handler_decl
503 = create_subprog_decl (get_identifier ("__gnat_end_handler_v1"), NULL_TREE,
504 ftype, NULL_TREE,
505 is_default, true, true, true, false, false, NULL,
506 Empty);
508 ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
509 unhandled_except_decl
510 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
511 NULL_TREE, ftype, NULL_TREE,
512 is_default, true, true, true, false, false, NULL,
513 Empty);
515 /* Indicate that it never returns. */
516 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
517 reraise_zcx_decl
518 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
519 ftype, NULL_TREE,
520 is_default, true, true, true, false, false, NULL,
521 Empty);
523 /* Dummy objects to materialize "others" and "all others" in the exception
524 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
525 the types to use. */
526 others_decl
527 = create_var_decl (get_identifier ("OTHERS"),
528 get_identifier ("__gnat_others_value"),
529 char_type_node, NULL_TREE,
530 true, false, true, false, false, true, false,
531 NULL, Empty);
533 all_others_decl
534 = create_var_decl (get_identifier ("ALL_OTHERS"),
535 get_identifier ("__gnat_all_others_value"),
536 char_type_node, NULL_TREE,
537 true, false, true, false, false, true, false,
538 NULL, Empty);
540 unhandled_others_decl
541 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
542 get_identifier ("__gnat_unhandled_others_value"),
543 char_type_node, NULL_TREE,
544 true, false, true, false, false, true, false,
545 NULL, Empty);
547 /* If in no exception handlers mode, all raise statements are redirected to
548 __gnat_last_chance_handler. */
549 if (No_Exception_Handlers_Set ())
551 /* Indicate that it never returns. */
552 ftype = build_function_type_list (void_type_node,
553 build_pointer_type (char_type_node),
554 integer_type_node, NULL_TREE);
555 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
556 tree decl
557 = create_subprog_decl
558 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, ftype,
559 NULL_TREE, is_default, true, true, true, false, false, NULL,
560 Empty);
561 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
562 gnat_raise_decls[i] = decl;
564 else
566 /* Otherwise, make one decl for each exception reason. */
567 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
568 gnat_raise_decls[i] = build_raise_check (i, exception_simple);
569 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
570 gnat_raise_decls_ext[i]
571 = build_raise_check (i,
572 i == CE_Index_Check_Failed
573 || i == CE_Range_Check_Failed
574 || i == CE_Invalid_Data
575 ? exception_range : exception_column);
578 /* Build the special descriptor type and its null node if needed. */
579 if (TARGET_VTABLE_USES_DESCRIPTORS)
581 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
582 tree field_list = NULL_TREE;
583 int j;
584 vec<constructor_elt, va_gc> *null_vec = NULL;
585 constructor_elt *elt;
587 fdesc_type_node = make_node (RECORD_TYPE);
588 vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS, true);
589 elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
591 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
593 tree field
594 = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
595 NULL_TREE, NULL_TREE, 0, 1);
596 DECL_CHAIN (field) = field_list;
597 field_list = field;
598 elt->index = field;
599 elt->value = null_node;
600 elt--;
603 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
604 record_builtin_type ("descriptor", fdesc_type_node, true);
605 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
608 longest_float_type_node
609 = get_unpadded_type (Base_Type (standard_long_long_float));
611 main_identifier_node = get_identifier ("main");
613 gnat_init_gcc_eh ();
615 /* Initialize the GCC support for FP operations. */
616 gnat_init_gcc_fp ();
618 /* Install the builtins we might need, either internally or as user-available
619 facilities for Intrinsic imports. Note that this must be done after the
620 GCC exception mechanism is initialized. */
621 gnat_install_builtins ();
623 vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
625 gnu_constraint_error_label_stack.safe_push (Empty);
626 gnu_storage_error_label_stack.safe_push (Empty);
627 gnu_program_error_label_stack.safe_push (Empty);
629 /* Process any Pragma Ident for the main unit. */
630 if (Present (Ident_String (Main_Unit)))
631 targetm.asm_out.output_ident
632 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
634 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
635 if (No_Strict_Aliasing_CP)
636 flag_strict_aliasing = 0;
638 /* Save the current optimization options again after the above possible
639 global_options changes. */
640 optimization_default_node
641 = build_optimization_node (&global_options, &global_options_set);
642 optimization_current_node = optimization_default_node;
644 /* Now translate the compilation unit proper. */
645 Compilation_Unit_to_gnu (gnat_root);
647 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
648 the very end to avoid having to second-guess the front-end when we run
649 into dummy nodes during the regular processing. */
650 for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++)
651 validate_unchecked_conversion (gnat_iter);
652 gnat_validate_uc_list.release ();
654 /* Finally see if we have any elaboration procedures to deal with. */
655 for (info = elab_info_list; info; info = info->next)
657 tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
659 /* We should have a BIND_EXPR but it may not have any statements in it.
660 If it doesn't have any, we have nothing to do except for setting the
661 flag on the GNAT node. Otherwise, process the function as others. */
662 tree gnu_stmts = gnu_body;
663 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
664 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
665 if (!gnu_stmts || empty_stmt_list_p (gnu_stmts))
666 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
667 else
669 begin_subprog_body (info->elab_proc);
670 end_subprog_body (gnu_body);
671 rest_of_subprog_body_compilation (info->elab_proc);
675 /* Destroy ourselves. */
676 file_map = NULL;
677 destroy_gnat_decl ();
678 destroy_gnat_utils ();
680 /* We cannot track the location of errors past this point. */
681 Current_Error_Node = Empty;
684 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
685 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
687 static tree
688 build_raise_check (int check, enum exception_info_kind kind)
690 tree result, ftype;
691 const char pfx[] = "__gnat_rcheck_";
693 strcpy (Name_Buffer, pfx);
694 Name_Len = sizeof (pfx) - 1;
695 Get_RT_Exception_Name ((enum RT_Exception_Code) check);
697 if (kind == exception_simple)
699 Name_Buffer[Name_Len] = 0;
700 ftype
701 = build_function_type_list (void_type_node,
702 build_pointer_type (char_type_node),
703 integer_type_node, NULL_TREE);
705 else
707 tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
709 strcpy (Name_Buffer + Name_Len, "_ext");
710 Name_Buffer[Name_Len + 4] = 0;
711 ftype
712 = build_function_type_list (void_type_node,
713 build_pointer_type (char_type_node),
714 integer_type_node, integer_type_node,
715 t, t, NULL_TREE);
718 /* Indicate that it never returns. */
719 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
720 result
721 = create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, ftype,
722 NULL_TREE, is_default, true, true, true, false,
723 false, NULL, Empty);
725 return result;
728 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
729 an N_Attribute_Reference. */
731 static int
732 lvalue_required_for_attribute_p (Node_Id gnat_node)
734 switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
736 case Attr_Pred:
737 case Attr_Succ:
738 case Attr_First:
739 case Attr_Last:
740 case Attr_Range_Length:
741 case Attr_Length:
742 case Attr_Object_Size:
743 case Attr_Size:
744 case Attr_Value_Size:
745 case Attr_Component_Size:
746 case Attr_Descriptor_Size:
747 case Attr_Max_Size_In_Storage_Elements:
748 case Attr_Min:
749 case Attr_Max:
750 case Attr_Null_Parameter:
751 case Attr_Passed_By_Reference:
752 case Attr_Mechanism_Code:
753 case Attr_Machine:
754 case Attr_Model:
755 return 0;
757 case Attr_Address:
758 case Attr_Access:
759 case Attr_Unchecked_Access:
760 case Attr_Unrestricted_Access:
761 case Attr_Code_Address:
762 case Attr_Pool_Address:
763 case Attr_Alignment:
764 case Attr_Bit_Position:
765 case Attr_Position:
766 case Attr_First_Bit:
767 case Attr_Last_Bit:
768 case Attr_Bit:
769 case Attr_Asm_Input:
770 case Attr_Asm_Output:
771 default:
772 return 1;
776 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
777 is the type that will be used for GNAT_NODE in the translated GNU tree.
778 CONSTANT indicates whether the underlying object represented by GNAT_NODE
779 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
780 whether its value is the address of another constant. If it isn't, then
781 ADDRESS_OF_CONSTANT is ignored.
783 The function climbs up the GNAT tree starting from the node and returns 1
784 upon encountering a node that effectively requires an lvalue downstream.
785 It returns int instead of bool to facilitate usage in non-purely binary
786 logic contexts. */
788 static int
789 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
790 bool address_of_constant)
792 Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
794 switch (Nkind (gnat_parent))
796 case N_Reference:
797 return 1;
799 case N_Attribute_Reference:
800 return lvalue_required_for_attribute_p (gnat_parent);
802 case N_Parameter_Association:
803 case N_Function_Call:
804 case N_Procedure_Call_Statement:
805 /* If the parameter is by reference, an lvalue is required. */
806 return (!constant
807 || must_pass_by_ref (gnu_type)
808 || default_pass_by_ref (gnu_type));
810 case N_Pragma_Argument_Association:
811 return lvalue_required_p (gnat_parent, gnu_type, constant,
812 address_of_constant);
814 case N_Pragma:
815 if (Is_Pragma_Name (Chars (Pragma_Identifier (gnat_parent))))
817 const unsigned char id
818 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_parent)));
819 return id == Pragma_Inspection_Point;
821 else
822 return 0;
824 case N_Indexed_Component:
825 /* Only the array expression can require an lvalue. */
826 if (Prefix (gnat_parent) != gnat_node)
827 return 0;
829 /* ??? Consider that referencing an indexed component with a variable
830 index forces the whole aggregate to memory. Note that testing only
831 for literals is conservative, any static expression in the RM sense
832 could probably be accepted with some additional work. */
833 for (gnat_temp = First (Expressions (gnat_parent));
834 Present (gnat_temp);
835 gnat_temp = Next (gnat_temp))
836 if (Nkind (gnat_temp) != N_Character_Literal
837 && Nkind (gnat_temp) != N_Integer_Literal
838 && !(Is_Entity_Name (gnat_temp)
839 && Ekind (Entity (gnat_temp)) == E_Enumeration_Literal))
840 return 1;
842 /* ... fall through ... */
844 case N_Selected_Component:
845 case N_Slice:
846 /* Only the prefix expression can require an lvalue. */
847 if (Prefix (gnat_parent) != gnat_node)
848 return 0;
850 return lvalue_required_p (gnat_parent,
851 get_unpadded_type (Etype (gnat_parent)),
852 constant, address_of_constant);
854 case N_Object_Renaming_Declaration:
855 /* We need to preserve addresses through a renaming. */
856 return 1;
858 case N_Object_Declaration:
859 /* We cannot use a constructor if this is an atomic object because
860 the actual assignment might end up being done component-wise. */
861 return (!constant
862 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
863 && Is_Full_Access (Defining_Entity (gnat_parent)))
864 /* We don't use a constructor if this is a class-wide object
865 because the effective type of the object is the equivalent
866 type of the class-wide subtype and it smashes most of the
867 data into an array of bytes to which we cannot convert. */
868 || Ekind ((Etype (Defining_Entity (gnat_parent))))
869 == E_Class_Wide_Subtype);
871 case N_Assignment_Statement:
872 /* We cannot use a constructor if the LHS is an atomic object because
873 the actual assignment might end up being done component-wise. */
874 return (!constant
875 || Name (gnat_parent) == gnat_node
876 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
877 && Is_Entity_Name (Name (gnat_parent))
878 && Is_Full_Access (Entity (Name (gnat_parent)))));
880 case N_Unchecked_Type_Conversion:
881 if (!constant)
882 return 1;
884 /* ... fall through ... */
886 case N_Type_Conversion:
887 case N_Qualified_Expression:
888 /* We must look through all conversions because we may need to bypass
889 an intermediate conversion that is meant to be purely formal. */
890 return lvalue_required_p (gnat_parent,
891 get_unpadded_type (Etype (gnat_parent)),
892 constant, address_of_constant);
894 case N_Explicit_Dereference:
895 /* We look through dereferences for address of constant because we need
896 to handle the special cases listed above. */
897 if (constant && address_of_constant)
898 return lvalue_required_p (gnat_parent,
899 get_unpadded_type (Etype (gnat_parent)),
900 true, false);
902 /* ... fall through ... */
904 default:
905 return 0;
908 gcc_unreachable ();
911 /* Return true if an lvalue should be used for GNAT_NODE. GNU_TYPE is the type
912 that will be used for GNAT_NODE in the translated GNU tree and is assumed to
913 be an aggregate type.
915 The function climbs up the GNAT tree starting from the node and returns true
916 upon encountering a node that makes it doable to decide. lvalue_required_p
917 should have been previously invoked on the arguments and returned false. */
919 static bool
920 lvalue_for_aggregate_p (Node_Id gnat_node, tree gnu_type)
922 Node_Id gnat_parent = Parent (gnat_node);
924 switch (Nkind (gnat_parent))
926 case N_Parameter_Association:
927 case N_Function_Call:
928 case N_Procedure_Call_Statement:
929 /* Even if the parameter is by copy, prefer an lvalue. */
930 return true;
932 case N_Simple_Return_Statement:
933 /* Likewise for a return value. */
934 return true;
936 case N_Indexed_Component:
937 case N_Selected_Component:
938 /* If an elementary component is used, take it from the constant. */
939 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_parent))))
940 return false;
942 /* ... fall through ... */
944 case N_Slice:
945 return lvalue_for_aggregate_p (gnat_parent,
946 get_unpadded_type (Etype (gnat_parent)));
948 case N_Object_Declaration:
949 /* For an aggregate object declaration, return false consistently. */
950 return false;
952 case N_Assignment_Statement:
953 /* For an aggregate assignment, decide based on the size. */
955 const HOST_WIDE_INT size = int_size_in_bytes (gnu_type);
956 return size < 0 || size >= param_large_stack_frame / 4;
959 case N_Unchecked_Type_Conversion:
960 case N_Type_Conversion:
961 case N_Qualified_Expression:
962 return lvalue_for_aggregate_p (gnat_parent,
963 get_unpadded_type (Etype (gnat_parent)));
965 case N_Allocator:
966 /* We should only reach here through the N_Qualified_Expression case.
967 Force an lvalue for aggregate types since a block-copy to the newly
968 allocated area of memory is made. */
969 return true;
971 default:
972 return false;
975 gcc_unreachable ();
979 /* Return true if T is a constant DECL node that can be safely replaced
980 by its initializer. */
982 static bool
983 constant_decl_with_initializer_p (tree t)
985 if (!TREE_CONSTANT (t) || !DECL_P (t) || !DECL_INITIAL (t))
986 return false;
988 /* Return false for aggregate types that contain a placeholder since
989 their initializers cannot be manipulated easily. */
990 if (AGGREGATE_TYPE_P (TREE_TYPE (t))
991 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t))
992 && type_contains_placeholder_p (TREE_TYPE (t)))
993 return false;
995 return true;
998 /* Return an expression equivalent to EXP but where constant DECL nodes
999 have been replaced by their initializer. */
1001 static tree
1002 fold_constant_decl_in_expr (tree exp)
1004 enum tree_code code = TREE_CODE (exp);
1005 tree op0;
1007 switch (code)
1009 case CONST_DECL:
1010 case VAR_DECL:
1011 if (!constant_decl_with_initializer_p (exp))
1012 return exp;
1014 return DECL_INITIAL (exp);
1016 case COMPONENT_REF:
1017 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1018 if (op0 == TREE_OPERAND (exp, 0))
1019 return exp;
1021 return fold_build3 (COMPONENT_REF, TREE_TYPE (exp), op0,
1022 TREE_OPERAND (exp, 1), NULL_TREE);
1024 case BIT_FIELD_REF:
1025 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1026 if (op0 == TREE_OPERAND (exp, 0))
1027 return exp;
1029 return fold_build3 (BIT_FIELD_REF, TREE_TYPE (exp), op0,
1030 TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
1032 case ARRAY_REF:
1033 case ARRAY_RANGE_REF:
1034 /* If the index is not itself constant, then nothing can be folded. */
1035 if (!TREE_CONSTANT (TREE_OPERAND (exp, 1)))
1036 return exp;
1037 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1038 if (op0 == TREE_OPERAND (exp, 0))
1039 return exp;
1041 return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
1042 TREE_OPERAND (exp, 2), TREE_OPERAND (exp, 3)));
1044 case REALPART_EXPR:
1045 case IMAGPART_EXPR:
1046 case VIEW_CONVERT_EXPR:
1047 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1048 if (op0 == TREE_OPERAND (exp, 0))
1049 return exp;
1051 return fold_build1 (code, TREE_TYPE (exp), op0);
1053 default:
1054 return exp;
1057 gcc_unreachable ();
1060 /* Return true if TYPE and DEF_TYPE are compatible GNAT types for Gigi. */
1062 static bool
1063 Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type)
1065 /* The trivial case. */
1066 if (type == def_type)
1067 return true;
1069 /* A class-wide type is equivalent to a subtype of itself. */
1070 if (Is_Class_Wide_Type (type))
1071 return true;
1073 /* A packed array type is compatible with its implementation type. */
1074 if (Is_Packed (def_type) && type == Packed_Array_Impl_Type (def_type))
1075 return true;
1077 /* If both types are Itypes, one may be a copy of the other. */
1078 if (Is_Itype (def_type) && Is_Itype (type))
1079 return true;
1081 /* If the type is incomplete and comes from a limited context, then also
1082 consider its non-limited view. */
1083 if (Is_Incomplete_Type (def_type)
1084 && From_Limited_With (def_type)
1085 && Present (Non_Limited_View (def_type)))
1086 return Gigi_Types_Compatible (type, Non_Limited_View (def_type));
1088 /* If the type is incomplete/private, then also consider its full view. */
1089 if (Is_Incomplete_Or_Private_Type (def_type)
1090 && Present (Full_View (def_type)))
1091 return Gigi_Types_Compatible (type, Full_View (def_type));
1093 return false;
1096 /* Return the full view of a private constant E, or of a renaming thereof, if
1097 its type has discriminants, and Empty otherwise. */
1099 static Entity_Id
1100 Full_View_Of_Private_Constant (Entity_Id E)
1102 while (Present (Renamed_Object (E)) && Is_Entity_Name (Renamed_Object (E)))
1103 E = Entity (Renamed_Object (E));
1105 if (Ekind (E) != E_Constant || No (Full_View (E)))
1106 return Empty;
1108 const Entity_Id T = Etype (E);
1110 if (Is_Private_Type (T)
1111 && (Has_Unknown_Discriminants (T)
1112 || (Present (Full_View (T)) && Has_Discriminants (Full_View (T)))))
1113 return Full_View (E);
1115 return Empty;
1118 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Identifier, to a GCC
1119 tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should
1120 place the result type. */
1122 static tree
1123 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
1125 Entity_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier
1126 || Nkind (gnat_node) == N_Defining_Operator_Symbol)
1127 ? gnat_node : Entity (gnat_node);
1128 Entity_Id gnat_result_type;
1129 tree gnu_result, gnu_result_type;
1130 /* If GNAT_NODE is a constant, whether we should use the initialization
1131 value instead of the constant entity, typically for scalars with an
1132 address clause when the parent doesn't require an lvalue. */
1133 bool use_constant_initializer;
1134 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1135 specific circumstances only, so evaluated lazily. < 0 means
1136 unknown, > 0 means known true, 0 means known false. */
1137 int require_lvalue;
1139 /* If the Etype of this node is not the same as that of the Entity, then
1140 something went wrong, probably in generic instantiation. However, this
1141 does not apply to types. Since we sometime have strange Ekind's, just
1142 do this test for objects, except for discriminants because their type
1143 may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */
1144 gcc_assert (!Is_Object (gnat_entity)
1145 || Ekind (gnat_entity) == E_Discriminant
1146 || Etype (gnat_node) == Etype (gnat_entity)
1147 || Gigi_Types_Compatible (Etype (gnat_node),
1148 Etype (gnat_entity)));
1150 /* If this is a reference to a deferred constant whose partial view is of
1151 unconstrained private type, the proper type is on the full view of the
1152 constant, not on the full view of the type which may be unconstrained. */
1153 const Entity_Id gnat_full_view = Full_View_Of_Private_Constant (gnat_entity);
1154 if (Present (gnat_full_view))
1156 gnat_entity = gnat_full_view;
1157 gnat_result_type = Etype (gnat_entity);
1159 else
1161 /* We use the Actual_Subtype only if it has already been elaborated,
1162 as we may be invoked precisely during its elaboration, otherwise
1163 the Etype. Avoid using it for packed arrays to simplify things,
1164 except in a return statement because we need the actual size and
1165 the front-end does not make it explicit in this case. */
1166 if ((Ekind (gnat_entity) == E_Constant
1167 || Ekind (gnat_entity) == E_Variable
1168 || Is_Formal (gnat_entity))
1169 && !(Is_Array_Type (Etype (gnat_entity))
1170 && Present (Packed_Array_Impl_Type (Etype (gnat_entity)))
1171 && Nkind (Parent (gnat_node)) != N_Simple_Return_Statement)
1172 && Present (Actual_Subtype (gnat_entity))
1173 && present_gnu_tree (Actual_Subtype (gnat_entity)))
1174 gnat_result_type = Actual_Subtype (gnat_entity);
1175 else
1176 gnat_result_type = Etype (gnat_node);
1179 /* Expand the type of this identifier first if it is needed, in case it is an
1180 enumeral literal, which only get made when the type is expanded. There is
1181 no order-of-elaboration issue here. */
1182 if (Is_Subprogram (gnat_entity))
1183 gnu_result_type = NULL_TREE;
1184 else
1185 gnu_result_type = get_unpadded_type (gnat_result_type);
1187 /* If this is a non-imported elementary constant with an address clause,
1188 retrieve the value instead of a pointer to be dereferenced unless
1189 an lvalue is required. This is generally more efficient and actually
1190 required if this is a static expression because it might be used
1191 in a context where a dereference is inappropriate, such as a case
1192 statement alternative or a record discriminant. There is no possible
1193 volatile-ness short-circuit here since Volatile constants must be
1194 imported per C.6. */
1195 if (Ekind (gnat_entity) == E_Constant
1196 && Is_Elementary_Type (gnat_result_type)
1197 && !Is_Imported (gnat_entity)
1198 && Present (Address_Clause (gnat_entity)))
1200 require_lvalue
1201 = lvalue_required_p (gnat_node, gnu_result_type, true, false);
1202 use_constant_initializer = !require_lvalue;
1204 else
1206 require_lvalue = -1;
1207 use_constant_initializer = false;
1210 /* Fetch the initialization value of a constant if requested. */
1211 if (use_constant_initializer)
1213 /* If this is a deferred constant, the initializer is attached to
1214 the full view. */
1215 if (Present (Full_View (gnat_entity)))
1216 gnat_entity = Full_View (gnat_entity);
1218 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
1220 else
1221 gnu_result = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
1223 /* Some objects (such as parameters passed by reference, globals of
1224 variable size, and renamed objects) actually represent the address
1225 of the object. In that case, we must do the dereference. Likewise,
1226 deal with parameters to foreign convention subprograms. */
1227 if (DECL_P (gnu_result)
1228 && (DECL_BY_REF_P (gnu_result)
1229 || (TREE_CODE (gnu_result) == PARM_DECL
1230 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
1232 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1234 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1235 if (TREE_CODE (gnu_result) == PARM_DECL
1236 && DECL_BY_COMPONENT_PTR_P (gnu_result))
1237 gnu_result
1238 = convert (build_pointer_type (gnu_result_type), gnu_result);
1240 /* If it's a CONST_DECL, return the underlying constant like below. */
1241 else if (TREE_CODE (gnu_result) == CONST_DECL
1242 && !(DECL_CONST_ADDRESS_P (gnu_result)
1243 && lvalue_required_p (gnat_node, gnu_result_type, true,
1244 true)))
1245 gnu_result = DECL_INITIAL (gnu_result);
1247 /* Do the final dereference. */
1248 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1250 if ((INDIRECT_REF_P (gnu_result)
1251 || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
1252 && No (Address_Clause (gnat_entity)))
1253 TREE_THIS_NOTRAP (gnu_result) = 1;
1255 if (read_only)
1256 TREE_READONLY (gnu_result) = 1;
1259 /* If we have a constant declaration and its initializer, try to return the
1260 latter to avoid the need to call fold in lots of places and the need for
1261 elaboration code if this identifier is used as an initializer itself. */
1262 if (constant_decl_with_initializer_p (gnu_result))
1264 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1265 && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1266 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1267 && DECL_CONST_ADDRESS_P (gnu_result));
1269 /* If there is a (corresponding) variable or this is the address of a
1270 constant, we only want to return the initializer if an lvalue isn't
1271 required. Evaluate this now if we have not already done so. */
1272 if ((!constant_only || address_of_constant) && require_lvalue < 0)
1273 require_lvalue
1274 = lvalue_required_p (gnat_node, gnu_result_type, true,
1275 address_of_constant)
1276 || (AGGREGATE_TYPE_P (gnu_result_type)
1277 && lvalue_for_aggregate_p (gnat_node, gnu_result_type));
1279 /* Finally retrieve the initializer if this is deemed valid. */
1280 if ((constant_only && !address_of_constant) || !require_lvalue)
1281 gnu_result = DECL_INITIAL (gnu_result);
1284 /* But for a constant renaming we couldn't do that incrementally for its
1285 definition because of the need to return an lvalue so, if the present
1286 context doesn't itself require an lvalue, we try again here. */
1287 else if (Ekind (gnat_entity) == E_Constant
1288 && Is_Elementary_Type (gnat_result_type)
1289 && Present (Renamed_Object (gnat_entity)))
1291 if (require_lvalue < 0)
1292 require_lvalue
1293 = lvalue_required_p (gnat_node, gnu_result_type, true, false);
1294 if (!require_lvalue)
1295 gnu_result = fold_constant_decl_in_expr (gnu_result);
1298 /* The GNAT tree has the type of a function set to its result type, so we
1299 adjust here. Also use the type of the result if the Etype is a subtype
1300 that is nominally unconstrained. Likewise if this is a deferred constant
1301 of a discriminated type whose full view can be elaborated statically, to
1302 avoid problematic conversions to the nominal subtype. But remove any
1303 padding from the resulting type. */
1304 if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result))
1305 || Is_Constr_Subt_For_UN_Aliased (gnat_result_type)
1306 || (Ekind (gnat_entity) == E_Constant
1307 && Present (Full_View (gnat_entity))
1308 && Has_Discriminants (gnat_result_type)
1309 && TREE_CODE (gnu_result) == CONSTRUCTOR))
1311 gnu_result_type = TREE_TYPE (gnu_result);
1312 if (TYPE_IS_PADDING_P (gnu_result_type))
1313 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1316 *gnu_result_type_p = gnu_result_type;
1318 return gnu_result;
1321 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Pragma, to a GCC
1322 tree, which is returned. */
1324 static tree
1325 Pragma_to_gnu (Node_Id gnat_node)
1327 tree gnu_result = alloc_stmt_list ();
1328 Node_Id gnat_temp;
1330 /* Check for (and ignore) unrecognized pragmas. */
1331 if (!Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1332 return gnu_result;
1334 const unsigned char id
1335 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
1337 /* Save the expression of pragma Compile_Time_{Error|Warning} for later. */
1338 if (id == Pragma_Compile_Time_Error || id == Pragma_Compile_Time_Warning)
1340 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1341 gnat_compile_time_expr_list.safe_push (Expression (gnat_temp));
1342 return gnu_result;
1345 /* Stop there if we are just annotating types. */
1346 if (type_annotate_only)
1347 return gnu_result;
1349 switch (id)
1351 case Pragma_Inspection_Point:
1352 /* Do nothing at top level: all such variables are already viewable. */
1353 if (global_bindings_p ())
1354 break;
1356 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1357 Present (gnat_temp);
1358 gnat_temp = Next (gnat_temp))
1360 Node_Id gnat_expr = Expression (gnat_temp);
1361 tree gnu_expr = gnat_to_gnu (gnat_expr);
1362 tree asm_constraint = NULL_TREE;
1363 #ifdef ASM_COMMENT_START
1364 char *comment;
1365 #endif
1366 gnu_expr = maybe_unconstrained_array (gnu_expr);
1367 if (TREE_CODE (gnu_expr) == CONST_DECL
1368 && DECL_CONST_CORRESPONDING_VAR (gnu_expr))
1369 gnu_expr = DECL_CONST_CORRESPONDING_VAR (gnu_expr);
1370 gnat_mark_addressable (gnu_expr);
1372 #ifdef ASM_COMMENT_START
1373 comment = concat (ASM_COMMENT_START,
1374 " inspection point: ",
1375 Get_Name_String (Chars (gnat_expr)),
1376 " is at %0",
1377 NULL);
1378 asm_constraint = build_string (strlen (comment), comment);
1379 free (comment);
1380 #endif
1381 gnu_expr = build5 (ASM_EXPR, void_type_node,
1382 asm_constraint,
1383 NULL_TREE,
1384 tree_cons
1385 (build_tree_list (NULL_TREE,
1386 build_string (1, "m")),
1387 gnu_expr, NULL_TREE),
1388 NULL_TREE, NULL_TREE);
1389 ASM_VOLATILE_P (gnu_expr) = 1;
1390 set_expr_location_from_node (gnu_expr, gnat_node);
1391 append_to_statement_list (gnu_expr, &gnu_result);
1393 break;
1395 case Pragma_Loop_Optimize:
1396 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1397 Present (gnat_temp);
1398 gnat_temp = Next (gnat_temp))
1400 tree gnu_loop_stmt = gnu_loop_stack->last ()->stmt;
1402 switch (Chars (Expression (gnat_temp)))
1404 case Name_Ivdep:
1405 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
1406 break;
1408 case Name_No_Unroll:
1409 LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1;
1410 break;
1412 case Name_Unroll:
1413 LOOP_STMT_UNROLL (gnu_loop_stmt) = 1;
1414 break;
1416 case Name_No_Vector:
1417 LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1;
1418 break;
1420 case Name_Vector:
1421 LOOP_STMT_VECTOR (gnu_loop_stmt) = 1;
1422 break;
1424 default:
1425 gcc_unreachable ();
1428 break;
1430 case Pragma_Optimize:
1431 switch (Chars (Expression
1432 (First (Pragma_Argument_Associations (gnat_node)))))
1434 case Name_Off:
1435 if (optimize)
1436 post_error ("must specify -O0??", gnat_node);
1437 break;
1439 case Name_Space:
1440 if (!optimize_size)
1441 post_error ("must specify -Os??", gnat_node);
1442 break;
1444 case Name_Time:
1445 if (!optimize)
1446 post_error ("insufficient -O value??", gnat_node);
1447 break;
1449 default:
1450 gcc_unreachable ();
1452 break;
1454 case Pragma_Reviewable:
1455 if (write_symbols == NO_DEBUG)
1456 post_error ("must specify -g??", gnat_node);
1457 break;
1459 case Pragma_Warning_As_Error:
1460 case Pragma_Warnings:
1462 Node_Id gnat_expr;
1463 /* Preserve the location of the pragma. */
1464 const location_t location = input_location;
1465 struct cl_option_handlers handlers;
1466 unsigned int option_index;
1467 diagnostic_t kind;
1468 bool imply;
1470 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1472 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1473 if (Nkind (Expression (gnat_temp)) == N_String_Literal)
1475 switch (id)
1477 case Pragma_Warning_As_Error:
1478 kind = DK_ERROR;
1479 imply = false;
1480 break;
1482 case Pragma_Warnings:
1483 kind = DK_WARNING;
1484 imply = true;
1485 break;
1487 default:
1488 gcc_unreachable ();
1491 gnat_expr = Expression (gnat_temp);
1494 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1495 else if (Nkind (Expression (gnat_temp)) == N_Identifier)
1497 switch (Chars (Expression (gnat_temp)))
1499 case Name_Off:
1500 kind = DK_IGNORED;
1501 break;
1503 case Name_On:
1504 kind = DK_WARNING;
1505 break;
1507 default:
1508 gcc_unreachable ();
1511 /* Deal with optional pattern (but ignore Reason => "..."). */
1512 if (Present (Next (gnat_temp))
1513 && Chars (Next (gnat_temp)) != Name_Reason)
1515 /* pragma Warnings (On | Off, Name) is handled differently. */
1516 if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal)
1517 break;
1519 gnat_expr = Expression (Next (gnat_temp));
1521 else
1523 gnat_expr = Empty;
1525 /* For pragma Warnings (Off), we save the current state... */
1526 if (kind == DK_IGNORED)
1527 diagnostic_push_diagnostics (global_dc, location);
1529 /* ...so that, for pragma Warnings (On), we do not enable all
1530 the warnings but just restore the previous state. */
1531 else
1533 diagnostic_pop_diagnostics (global_dc, location);
1534 break;
1538 imply = false;
1541 else
1542 gcc_unreachable ();
1544 /* This is the same implementation as in the C family of compilers. */
1545 const unsigned int lang_mask = CL_Ada | CL_COMMON;
1546 const char *arg = NULL;
1547 if (Present (gnat_expr))
1549 tree gnu_expr = gnat_to_gnu (gnat_expr);
1550 const char *option_string = TREE_STRING_POINTER (gnu_expr);
1551 const int len = TREE_STRING_LENGTH (gnu_expr);
1552 if (len < 3 || option_string[0] != '-' || option_string[1] != 'W')
1553 break;
1554 option_index = find_opt (option_string + 1, lang_mask);
1555 if (option_index == OPT_SPECIAL_unknown)
1557 post_error ("unknown -W switch??", gnat_node);
1558 break;
1560 else if (!(cl_options[option_index].flags & CL_WARNING))
1562 post_error ("-W switch does not control warning??", gnat_node);
1563 break;
1565 else if (!(cl_options[option_index].flags & lang_mask))
1567 post_error ("-W switch not valid for Ada??", gnat_node);
1568 break;
1570 if (cl_options[option_index].flags & CL_JOINED)
1571 arg = option_string + 1 + cl_options[option_index].opt_len;
1573 else
1574 option_index = 0;
1576 set_default_handlers (&handlers, NULL);
1577 control_warning_option (option_index, (int) kind, arg, imply, location,
1578 lang_mask, &handlers, &global_options,
1579 &global_options_set, global_dc);
1581 break;
1583 default:
1584 break;
1587 return gnu_result;
1590 /* Check the inline status of nested function FNDECL wrt its parent function.
1592 If a non-inline nested function is referenced from an inline external
1593 function, we cannot honor both requests at the same time without cloning
1594 the nested function in the current unit since it is private to its unit.
1595 We could inline it as well but it's probably better to err on the side
1596 of too little inlining.
1598 This must be done only on nested functions present in the source code
1599 and not on nested functions generated by the compiler, e.g. finalizers,
1600 because they may be not marked inline and we don't want them to block
1601 the inlining of the parent function. */
1603 static void
1604 check_inlining_for_nested_subprog (tree fndecl)
1606 if (DECL_IGNORED_P (current_function_decl) || DECL_IGNORED_P (fndecl))
1607 return;
1609 if (DECL_DECLARED_INLINE_P (fndecl))
1610 return;
1612 tree parent_decl = decl_function_context (fndecl);
1613 if (DECL_EXTERNAL (parent_decl) && DECL_DECLARED_INLINE_P (parent_decl))
1615 const location_t loc1 = DECL_SOURCE_LOCATION (fndecl);
1616 const location_t loc2 = DECL_SOURCE_LOCATION (parent_decl);
1618 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl)))
1620 error_at (loc1, "subprogram %q+F not marked %<Inline_Always%>",
1621 fndecl);
1622 error_at (loc2, "parent subprogram cannot be inlined");
1624 else
1626 warning_at (loc1, OPT_Winline, "subprogram %q+F not marked %<Inline%>",
1627 fndecl);
1628 warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined");
1631 DECL_DECLARED_INLINE_P (parent_decl) = 0;
1632 DECL_UNINLINABLE (parent_decl) = 1;
1636 /* Return an expression for the length of TYPE, an integral type, computed in
1637 RESULT_TYPE, another integral type.
1639 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1640 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1641 which would only overflow in much rarer cases, for extremely large arrays
1642 we expect never to encounter in practice. Besides, the former computation
1643 required the use of potentially constraining signed arithmetics while the
1644 latter does not. Note that the comparison must be done in the original
1645 base index type in order to avoid any overflow during the conversion. */
1647 static tree
1648 get_type_length (tree type, tree result_type)
1650 tree comp_type = get_base_type (result_type);
1651 tree base_type = maybe_character_type (get_base_type (type));
1652 tree lb = convert (base_type, TYPE_MIN_VALUE (type));
1653 tree hb = convert (base_type, TYPE_MAX_VALUE (type));
1654 tree length
1655 = build_binary_op (PLUS_EXPR, comp_type,
1656 build_binary_op (MINUS_EXPR, comp_type,
1657 convert (comp_type, hb),
1658 convert (comp_type, lb)),
1659 build_int_cst (comp_type, 1));
1660 length
1661 = build_cond_expr (result_type,
1662 build_binary_op (GE_EXPR, boolean_type_node, hb, lb),
1663 convert (result_type, length),
1664 build_int_cst (result_type, 0));
1665 return length;
1668 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node, to a
1669 GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we
1670 should place the result type. ATTRIBUTE is the attribute ID. */
1672 static tree
1673 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1675 const Node_Id gnat_prefix = Prefix (gnat_node);
1676 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
1677 tree gnu_type = TREE_TYPE (gnu_prefix);
1678 tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1679 bool prefix_unused = false;
1680 Entity_Id gnat_smo;
1682 /* If the input is a NULL_EXPR, make a new one. */
1683 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1685 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1686 *gnu_result_type_p = gnu_result_type;
1687 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1690 /* If the input is a LOAD_EXPR of an unconstrained array type, the second
1691 operand contains the storage model object. */
1692 if (TREE_CODE (gnu_prefix) == LOAD_EXPR
1693 && TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1694 gnat_smo = tree_to_shwi (TREE_OPERAND (gnu_prefix, 1));
1695 else
1696 gnat_smo = Empty;
1698 switch (attribute)
1700 case Attr_Pred:
1701 case Attr_Succ:
1702 /* These just add or subtract the constant 1 since representation
1703 clauses for enumeration types are handled in the front-end. */
1704 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1705 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1706 gnu_type = maybe_character_type (gnu_result_type);
1707 if (TREE_TYPE (gnu_expr) != gnu_type)
1708 gnu_expr = convert (gnu_type, gnu_expr);
1709 gnu_result
1710 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1711 gnu_type, gnu_expr, build_int_cst (gnu_type, 1));
1712 break;
1714 case Attr_Address:
1715 case Attr_Unrestricted_Access:
1716 /* Conversions don't change the address of references but can cause
1717 build_unary_op to miss the references below, so strip them off.
1718 On the contrary, if the address-of operation causes a temporary
1719 to be created, then it must be created with the proper type. */
1720 gnu_expr = remove_conversions (gnu_prefix,
1721 !Must_Be_Byte_Aligned (gnat_node));
1722 if (REFERENCE_CLASS_P (gnu_expr))
1723 gnu_prefix = gnu_expr;
1725 /* If we are taking 'Address of an unconstrained object, this is the
1726 pointer to the underlying array. */
1727 if (attribute == Attr_Address)
1728 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1730 /* If we are building a static dispatch table, we have to honor
1731 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1732 with the C++ ABI. We do it in the non-static case as well,
1733 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1734 else if (TARGET_VTABLE_USES_DESCRIPTORS
1735 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1737 tree gnu_field, t;
1738 /* Descriptors can only be built here for top-level functions. */
1739 bool build_descriptor = (global_bindings_p () != 0);
1740 int i;
1741 vec<constructor_elt, va_gc> *gnu_vec = NULL;
1742 constructor_elt *elt;
1744 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1746 /* If we're not going to build the descriptor, we have to retrieve
1747 the one which will be built by the linker (or by the compiler
1748 later if a static chain is requested). */
1749 if (!build_descriptor)
1751 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1752 gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1753 gnu_result);
1754 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1757 vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS, true);
1758 elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1759 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1760 i < TARGET_VTABLE_USES_DESCRIPTORS;
1761 gnu_field = DECL_CHAIN (gnu_field), i++)
1763 if (build_descriptor)
1765 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1766 build_int_cst (NULL_TREE, i));
1767 TREE_CONSTANT (t) = 1;
1769 else
1770 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1771 gnu_field, NULL_TREE);
1773 elt->index = gnu_field;
1774 elt->value = t;
1775 elt--;
1778 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1779 break;
1782 /* ... fall through ... */
1784 case Attr_Access:
1785 case Attr_Unchecked_Access:
1786 case Attr_Code_Address:
1787 /* Taking the address of a type does not make sense. */
1788 gcc_assert (TREE_CODE (gnu_prefix) != TYPE_DECL);
1790 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1791 gnu_result
1792 = build_unary_op (((attribute == Attr_Address
1793 || attribute == Attr_Unrestricted_Access)
1794 && !Must_Be_Byte_Aligned (gnat_node))
1795 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1796 gnu_result_type, gnu_prefix);
1798 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1799 don't try to build a trampoline. */
1800 if (attribute == Attr_Code_Address)
1802 gnu_expr = remove_conversions (gnu_result, false);
1804 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1805 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1807 /* On targets for which function symbols denote a descriptor, the
1808 code address is stored within the first slot of the descriptor
1809 so we do an additional dereference:
1810 result = *((result_type *) result)
1811 where we expect result to be of some pointer type already. */
1812 if (targetm.calls.custom_function_descriptors == 0)
1813 gnu_result
1814 = build_unary_op (INDIRECT_REF, NULL_TREE,
1815 convert (build_pointer_type (gnu_result_type),
1816 gnu_result));
1819 /* For 'Access, issue an error message if the prefix is a C++ method
1820 since it can use a special calling convention on some platforms,
1821 which cannot be propagated to the access type. */
1822 else if (attribute == Attr_Access
1823 && TREE_CODE (TREE_TYPE (gnu_prefix)) == METHOD_TYPE)
1824 post_error ("access to C++ constructor or member function not allowed",
1825 gnat_node);
1827 /* For other address attributes applied to a nested function,
1828 find an inner ADDR_EXPR and annotate it so that we can issue
1829 a useful warning with -Wtrampolines. */
1830 else if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_prefix))
1831 && (gnu_expr = remove_conversions (gnu_result, false))
1832 && TREE_CODE (gnu_expr) == ADDR_EXPR
1833 && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1835 set_expr_location_from_node (gnu_expr, gnat_node);
1837 /* Also check the inlining status. */
1838 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
1840 /* Moreover, for 'Access or 'Unrestricted_Access with non-
1841 foreign-compatible representation, mark the ADDR_EXPR so
1842 that we can build a descriptor instead of a trampoline. */
1843 if ((attribute == Attr_Access
1844 || attribute == Attr_Unrestricted_Access)
1845 && targetm.calls.custom_function_descriptors > 0
1846 && Can_Use_Internal_Rep (Underlying_Type (Etype (gnat_node))))
1847 FUNC_ADDR_BY_DESCRIPTOR (gnu_expr) = 1;
1849 /* Otherwise, we need to check that we are not violating the
1850 No_Implicit_Dynamic_Code restriction. */
1851 else if (targetm.calls.custom_function_descriptors != 0)
1852 Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1854 break;
1856 case Attr_Pool_Address:
1858 tree gnu_ptr = gnu_prefix;
1859 tree gnu_obj_type;
1861 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1863 /* If this is fat pointer, the object must have been allocated with the
1864 template in front of the array. So compute the template address; do
1865 it by converting to a thin pointer. */
1866 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1867 gnu_ptr
1868 = convert (build_pointer_type
1869 (TYPE_OBJECT_RECORD_TYPE
1870 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1871 gnu_ptr);
1873 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1875 /* If this is a thin pointer, the object must have been allocated with
1876 the template in front of the array. So compute the template address
1877 and return it. */
1878 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
1879 gnu_ptr
1880 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
1881 gnu_ptr,
1882 fold_build1 (NEGATE_EXPR, sizetype,
1883 byte_position
1884 (DECL_CHAIN
1885 TYPE_FIELDS ((gnu_obj_type)))));
1887 gnu_result = convert (gnu_result_type, gnu_ptr);
1889 break;
1891 case Attr_Size:
1892 case Attr_Object_Size:
1893 case Attr_Value_Size:
1894 case Attr_Max_Size_In_Storage_Elements:
1895 /* Strip NOPs, conversions between original and packable versions, and
1896 unpadding from GNU_PREFIX. Note that we cannot simply strip every
1897 VIEW_CONVERT_EXPR because some of them may give the actual size, e.g.
1898 for nominally unconstrained packed array. We use GNU_EXPR to see
1899 if a COMPONENT_REF was involved. */
1900 while (CONVERT_EXPR_P (gnu_prefix)
1901 || TREE_CODE (gnu_prefix) == NON_LVALUE_EXPR
1902 || (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
1903 && TREE_CODE (TREE_TYPE (gnu_prefix)) == RECORD_TYPE
1904 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1905 == RECORD_TYPE
1906 && TYPE_NAME (TREE_TYPE (gnu_prefix))
1907 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1908 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1909 gnu_expr = gnu_prefix;
1910 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1911 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1912 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1913 prefix_unused = true;
1914 gnu_type = TREE_TYPE (gnu_prefix);
1916 /* Replace an unconstrained array type with the type of the underlying
1917 array, except for 'Max_Size_In_Storage_Elements because we need to
1918 return the (maximum) size requested for an allocator. */
1919 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1921 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1922 if (attribute != Attr_Max_Size_In_Storage_Elements)
1923 gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1926 /* The type must be frozen at this point. */
1927 gcc_assert (COMPLETE_TYPE_P (gnu_type));
1929 /* If we're looking for the size of a field, return the field size. */
1930 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1931 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1933 /* Otherwise, if the prefix is an object, or if we are looking for
1934 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1935 GCC size of the type. We make an exception for padded objects,
1936 as we do not take into account alignment promotions for the size.
1937 This is in keeping with the object case of gnat_to_gnu_entity. */
1938 else if ((TREE_CODE (gnu_prefix) != TYPE_DECL
1939 && !(TYPE_IS_PADDING_P (gnu_type)
1940 && TREE_CODE (gnu_expr) == COMPONENT_REF
1941 && pad_type_has_rm_size (gnu_type)))
1942 || attribute == Attr_Object_Size
1943 || attribute == Attr_Max_Size_In_Storage_Elements)
1945 /* If this is a dereference and we have a special dynamic constrained
1946 subtype on the prefix, use it to compute the size; otherwise, use
1947 the designated subtype. */
1948 if (Nkind (gnat_prefix) == N_Explicit_Dereference)
1950 Node_Id gnat_actual_subtype
1951 = Actual_Designated_Subtype (gnat_prefix);
1952 tree gnu_ptr_type
1953 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
1955 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1956 && Present (gnat_actual_subtype))
1958 tree gnu_actual_obj_type
1959 = gnat_to_gnu_type (gnat_actual_subtype);
1960 gnu_type
1961 = build_unc_object_type_from_ptr (gnu_ptr_type,
1962 gnu_actual_obj_type,
1963 get_identifier ("SIZE"),
1964 false);
1968 gnu_result = TYPE_SIZE (gnu_type);
1971 /* Otherwise, the result is the RM size of the type. */
1972 else
1973 gnu_result = rm_size (gnu_type);
1975 /* Deal with a self-referential size by qualifying the size with the
1976 object or returning the maximum size for a type. */
1977 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1979 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1980 if (Present (gnat_smo))
1981 gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
1983 else if (CONTAINS_PLACEHOLDER_P (gnu_result))
1984 gnu_result = max_size (gnu_result, true);
1986 /* If the type contains a template, subtract the padded size of the
1987 template, except for 'Max_Size_In_Storage_Elements because we need
1988 to return the (maximum) size requested for an allocator. */
1989 if (TREE_CODE (gnu_type) == RECORD_TYPE
1990 && TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1991 && attribute != Attr_Max_Size_In_Storage_Elements)
1992 gnu_result
1993 = size_binop (MINUS_EXPR, gnu_result,
1994 bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
1996 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
1997 if (attribute == Attr_Max_Size_In_Storage_Elements)
1998 gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
2000 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2001 break;
2003 case Attr_Alignment:
2005 unsigned int align;
2007 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
2008 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
2009 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
2011 gnu_type = TREE_TYPE (gnu_prefix);
2012 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2013 prefix_unused = true;
2015 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2016 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
2017 else
2019 Entity_Id gnat_type = Etype (gnat_prefix);
2020 unsigned int double_align;
2021 bool is_capped_double, align_clause;
2023 /* If the default alignment of "double" or larger scalar types is
2024 specifically capped and there is an alignment clause neither
2025 on the type nor on the prefix itself, return the cap. */
2026 if ((double_align = double_float_alignment) > 0)
2027 is_capped_double
2028 = is_double_float_or_array (gnat_type, &align_clause);
2029 else if ((double_align = double_scalar_alignment) > 0)
2030 is_capped_double
2031 = is_double_scalar_or_array (gnat_type, &align_clause);
2032 else
2033 is_capped_double = align_clause = false;
2035 if (is_capped_double
2036 && Nkind (gnat_prefix) == N_Identifier
2037 && Present (Alignment_Clause (Entity (gnat_prefix))))
2038 align_clause = true;
2040 if (is_capped_double && !align_clause)
2041 align = double_align;
2042 else
2043 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
2046 gnu_result = size_int (align);
2048 break;
2050 case Attr_First:
2051 case Attr_Last:
2052 case Attr_Range_Length:
2053 prefix_unused = true;
2055 if (INTEGRAL_TYPE_P (gnu_type) || SCALAR_FLOAT_TYPE_P (gnu_type))
2057 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2059 if (attribute == Attr_First)
2060 gnu_result = TYPE_MIN_VALUE (gnu_type);
2061 else if (attribute == Attr_Last)
2062 gnu_result = TYPE_MAX_VALUE (gnu_type);
2063 else
2064 gnu_result = get_type_length (gnu_type, gnu_result_type);
2065 break;
2068 /* ... fall through ... */
2070 case Attr_Length:
2072 int Dimension = (Present (Expressions (gnat_node))
2073 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
2074 : 1), i;
2075 struct parm_attr_d *pa = NULL;
2076 Entity_Id gnat_param = Empty;
2077 bool unconstrained_ptr_deref = false;
2079 gnu_prefix = maybe_padded_object (gnu_prefix);
2080 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
2082 /* We treat unconstrained array In parameters specially. We also note
2083 whether we are dereferencing a pointer to unconstrained array. */
2084 if (!Is_Constrained (Etype (gnat_prefix)))
2085 switch (Nkind (gnat_prefix))
2087 case N_Identifier:
2088 /* This is the direct case. */
2089 if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
2090 gnat_param = Entity (gnat_prefix);
2091 break;
2093 case N_Explicit_Dereference:
2094 /* This is the indirect case. Note that we need to be sure that
2095 the access value cannot be null as we'll hoist the load. */
2096 if (Nkind (Prefix (gnat_prefix)) == N_Identifier
2097 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
2099 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
2100 gnat_param = Entity (Prefix (gnat_prefix));
2102 else
2103 unconstrained_ptr_deref = true;
2104 break;
2106 default:
2107 break;
2110 /* If the prefix is the view conversion of a constrained array to an
2111 unconstrained form, we retrieve the constrained array because we
2112 might not be able to substitute the PLACEHOLDER_EXPR coming from
2113 the conversion. This can occur with the 'Old attribute applied
2114 to a parameter with an unconstrained type, which gets rewritten
2115 into a constrained local variable very late in the game. */
2116 if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
2117 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix)))
2118 && !CONTAINS_PLACEHOLDER_P
2119 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
2120 gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0));
2121 else
2122 gnu_type = TREE_TYPE (gnu_prefix);
2124 prefix_unused = true;
2125 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2127 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
2129 int ndim;
2130 tree gnu_type_temp;
2132 for (ndim = 1, gnu_type_temp = gnu_type;
2133 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
2134 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
2135 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
2138 Dimension = ndim + 1 - Dimension;
2141 for (i = 1; i < Dimension; i++)
2142 gnu_type = TREE_TYPE (gnu_type);
2144 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2146 /* When not optimizing, look up the slot associated with the parameter
2147 and the dimension in the cache and create a new one on failure.
2148 Don't do this when the actual subtype needs debug info (this happens
2149 with -gnatD): in elaborate_expression_1, we create variables that
2150 hold the bounds, so caching attributes isn't very interesting and
2151 causes dependency issues between these variables and cached
2152 expressions. */
2153 if (!optimize
2154 && Present (gnat_param)
2155 && !(Present (Actual_Subtype (gnat_param))
2156 && Needs_Debug_Info (Actual_Subtype (gnat_param))))
2158 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa)
2159 if (pa->id == gnat_param && pa->dim == Dimension)
2160 break;
2162 if (!pa)
2164 pa = ggc_cleared_alloc<parm_attr_d> ();
2165 pa->id = gnat_param;
2166 pa->dim = Dimension;
2167 vec_safe_push (f_parm_attr_cache, pa);
2171 /* Return the cached expression or build a new one. */
2172 if (attribute == Attr_First)
2174 if (pa && pa->first)
2176 gnu_result = pa->first;
2177 break;
2180 gnu_result
2181 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2184 else if (attribute == Attr_Last)
2186 if (pa && pa->last)
2188 gnu_result = pa->last;
2189 break;
2192 gnu_result
2193 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2196 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2198 if (pa && pa->length)
2200 gnu_result = pa->length;
2201 break;
2204 gnu_result
2205 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)),
2206 gnu_result_type);
2209 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2210 handling. Note that these attributes could not have been used on
2211 an unconstrained array type. */
2212 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2213 if (Present (gnat_smo))
2214 gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
2216 /* Cache the expression we have just computed. Since we want to do it
2217 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2218 create the temporary in the outermost binding level. We will make
2219 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2220 paths by forcing its evaluation on entry of the function. */
2221 if (pa)
2223 gnu_result
2224 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2225 switch (attribute)
2227 case Attr_First:
2228 pa->first = gnu_result;
2229 break;
2231 case Attr_Last:
2232 pa->last = gnu_result;
2233 break;
2235 case Attr_Length:
2236 case Attr_Range_Length:
2237 pa->length = gnu_result;
2238 break;
2240 default:
2241 gcc_unreachable ();
2245 /* Otherwise, evaluate it each time it is referenced. */
2246 else
2247 switch (attribute)
2249 case Attr_First:
2250 case Attr_Last:
2251 /* If we are dereferencing a pointer to unconstrained array, we
2252 need to capture the value because the pointed-to bounds may
2253 subsequently be released. */
2254 if (unconstrained_ptr_deref)
2255 gnu_result
2256 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2257 break;
2259 case Attr_Length:
2260 case Attr_Range_Length:
2261 /* Set the source location onto the predicate of the condition
2262 but not if the expression is cached to avoid messing up the
2263 debug info. */
2264 if (TREE_CODE (gnu_result) == COND_EXPR
2265 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
2266 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
2267 gnat_node);
2268 break;
2270 default:
2271 gcc_unreachable ();
2274 break;
2277 case Attr_Bit_Position:
2278 case Attr_Position:
2279 case Attr_First_Bit:
2280 case Attr_Last_Bit:
2281 case Attr_Bit:
2283 poly_int64 bitsize;
2284 poly_int64 bitpos;
2285 tree gnu_offset;
2286 tree gnu_field_bitpos;
2287 tree gnu_field_offset;
2288 tree gnu_inner;
2289 machine_mode mode;
2290 int unsignedp, reversep, volatilep;
2292 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2293 gnu_prefix = remove_conversions (gnu_prefix, true);
2294 prefix_unused = true;
2296 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2297 the result is 0. Don't allow 'Bit on a bare component, though. */
2298 if (attribute == Attr_Bit
2299 && TREE_CODE (gnu_prefix) != COMPONENT_REF
2300 && TREE_CODE (gnu_prefix) != FIELD_DECL)
2302 gnu_result = integer_zero_node;
2303 break;
2306 else
2307 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
2308 || (attribute == Attr_Bit_Position
2309 && TREE_CODE (gnu_prefix) == FIELD_DECL));
2311 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
2312 &mode, &unsignedp, &reversep, &volatilep);
2314 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2316 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
2317 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
2319 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
2320 TREE_CODE (gnu_inner) == COMPONENT_REF
2321 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
2322 gnu_inner = TREE_OPERAND (gnu_inner, 0))
2324 gnu_field_bitpos
2325 = size_binop (PLUS_EXPR, gnu_field_bitpos,
2326 bit_position (TREE_OPERAND (gnu_inner, 1)));
2327 gnu_field_offset
2328 = size_binop (PLUS_EXPR, gnu_field_offset,
2329 byte_position (TREE_OPERAND (gnu_inner, 1)));
2332 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
2334 gnu_field_bitpos = bit_position (gnu_prefix);
2335 gnu_field_offset = byte_position (gnu_prefix);
2337 else
2339 gnu_field_bitpos = bitsize_zero_node;
2340 gnu_field_offset = size_zero_node;
2343 switch (attribute)
2345 case Attr_Position:
2346 gnu_result = gnu_field_offset;
2347 break;
2349 case Attr_First_Bit:
2350 case Attr_Bit:
2351 gnu_result = size_int (num_trailing_bits (bitpos));
2352 break;
2354 case Attr_Last_Bit:
2355 gnu_result = bitsize_int (num_trailing_bits (bitpos));
2356 gnu_result = size_binop (PLUS_EXPR, gnu_result,
2357 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
2358 /* ??? Avoid a large unsigned result that will overflow when
2359 converted to the signed universal_integer. */
2360 if (integer_zerop (gnu_result))
2361 gnu_result = integer_minus_one_node;
2362 else
2363 gnu_result
2364 = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node);
2365 break;
2367 case Attr_Bit_Position:
2368 gnu_result = gnu_field_bitpos;
2369 break;
2372 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2373 handling. */
2374 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2375 if (Present (gnat_smo))
2376 gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
2377 break;
2380 case Attr_Min:
2381 case Attr_Max:
2383 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
2384 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
2386 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2388 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2389 a NaN so we implement the semantics of C99 f{min,max} to make it
2390 predictable in this case: if either operand is a NaN, the other
2391 is returned; if both operands are NaN's, a NaN is returned. */
2392 if (SCALAR_FLOAT_TYPE_P (gnu_result_type)
2393 && !Machine_Overflows_On_Target)
2395 const bool lhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_lhs);
2396 const bool rhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_rhs);
2397 tree t = builtin_decl_explicit (BUILT_IN_ISNAN);
2398 tree lhs_is_nan, rhs_is_nan;
2400 /* If the operands have side-effects, they need to be evaluated
2401 only once in spite of the multiple references in the result. */
2402 if (lhs_side_effects_p)
2403 gnu_lhs = gnat_protect_expr (gnu_lhs);
2404 if (rhs_side_effects_p)
2405 gnu_rhs = gnat_protect_expr (gnu_rhs);
2407 lhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2408 build_call_expr (t, 1, gnu_lhs),
2409 integer_zero_node);
2411 rhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2412 build_call_expr (t, 1, gnu_rhs),
2413 integer_zero_node);
2415 gnu_result = build_binary_op (attribute == Attr_Min
2416 ? MIN_EXPR : MAX_EXPR,
2417 gnu_result_type, gnu_lhs, gnu_rhs);
2418 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2419 rhs_is_nan, gnu_lhs, gnu_result);
2420 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2421 lhs_is_nan, gnu_rhs, gnu_result);
2423 /* If the operands have side-effects, they need to be evaluated
2424 before doing the tests above since the place they otherwise
2425 would end up being evaluated at run time could be wrong. */
2426 if (lhs_side_effects_p)
2427 gnu_result
2428 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_lhs, gnu_result);
2430 if (rhs_side_effects_p)
2431 gnu_result
2432 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_rhs, gnu_result);
2434 else
2435 gnu_result = build_binary_op (attribute == Attr_Min
2436 ? MIN_EXPR : MAX_EXPR,
2437 gnu_result_type, gnu_lhs, gnu_rhs);
2439 break;
2441 case Attr_Passed_By_Reference:
2442 gnu_result = size_int (default_pass_by_ref (gnu_type)
2443 || must_pass_by_ref (gnu_type));
2444 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2445 break;
2447 case Attr_Component_Size:
2448 gnu_prefix = maybe_padded_object (gnu_prefix);
2449 gnu_type = TREE_TYPE (gnu_prefix);
2451 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2452 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
2454 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2455 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
2456 gnu_type = TREE_TYPE (gnu_type);
2458 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2460 /* Note this size cannot be self-referential. */
2461 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
2462 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2463 prefix_unused = true;
2464 break;
2466 case Attr_Descriptor_Size:
2467 gnu_type = TREE_TYPE (gnu_prefix);
2468 gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
2470 /* Return the padded size of the template in the object record type. */
2471 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
2472 gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
2473 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2474 prefix_unused = true;
2475 break;
2477 case Attr_Null_Parameter:
2478 /* This is just a zero cast to the pointer type for our prefix and
2479 dereferenced. */
2480 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2481 gnu_result
2482 = build_unary_op (INDIRECT_REF, NULL_TREE,
2483 convert (build_pointer_type (gnu_result_type),
2484 integer_zero_node));
2485 break;
2487 case Attr_Mechanism_Code:
2489 Entity_Id gnat_obj = Entity (gnat_prefix);
2490 int code;
2492 prefix_unused = true;
2493 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2494 if (Present (Expressions (gnat_node)))
2496 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
2498 for (gnat_obj = First_Formal (gnat_obj); i > 1;
2499 i--, gnat_obj = Next_Formal (gnat_obj))
2503 code = Mechanism (gnat_obj);
2504 if (code == Default)
2505 code = ((present_gnu_tree (gnat_obj)
2506 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
2507 || ((TREE_CODE (get_gnu_tree (gnat_obj))
2508 == PARM_DECL)
2509 && (DECL_BY_COMPONENT_PTR_P
2510 (get_gnu_tree (gnat_obj))))))
2511 ? By_Reference : By_Copy);
2512 gnu_result = convert (gnu_result_type, size_int (- code));
2514 break;
2516 case Attr_Model:
2517 /* We treat Model as identical to Machine. This is true for at least
2518 IEEE and some other nice floating-point systems. */
2520 /* ... fall through ... */
2522 case Attr_Machine:
2523 /* The trick is to force the compiler to store the result in memory so
2524 that we do not have extra precision used. But do this only when this
2525 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2526 the type is lower than that of the longest floating-point type. */
2527 prefix_unused = true;
2528 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2529 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2530 gnu_result = convert (gnu_result_type, gnu_expr);
2532 if (TREE_CODE (gnu_result) != REAL_CST
2533 && fp_arith_may_widen
2534 && TYPE_PRECISION (gnu_result_type)
2535 < TYPE_PRECISION (longest_float_type_node))
2537 tree rec_type = make_node (RECORD_TYPE);
2538 tree field
2539 = create_field_decl (get_identifier ("OBJ"), gnu_result_type,
2540 rec_type, NULL_TREE, NULL_TREE, 0, 0);
2541 tree rec_val, asm_expr;
2543 finish_record_type (rec_type, field, 0, false);
2545 rec_val = build_constructor_single (rec_type, field, gnu_result);
2546 rec_val = build1 (SAVE_EXPR, rec_type, rec_val);
2548 asm_expr
2549 = build5 (ASM_EXPR, void_type_node,
2550 build_string (0, ""),
2551 tree_cons (build_tree_list (NULL_TREE,
2552 build_string (2, "=m")),
2553 rec_val, NULL_TREE),
2554 tree_cons (build_tree_list (NULL_TREE,
2555 build_string (1, "m")),
2556 rec_val, NULL_TREE),
2557 NULL_TREE, NULL_TREE);
2558 ASM_VOLATILE_P (asm_expr) = 1;
2560 gnu_result
2561 = build_compound_expr (gnu_result_type, asm_expr,
2562 build_component_ref (rec_val, field,
2563 false));
2565 break;
2567 case Attr_Deref:
2568 prefix_unused = true;
2569 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2570 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2571 /* This can be a random address so build an alias-all pointer type. */
2572 gnu_expr
2573 = convert (build_pointer_type_for_mode (gnu_result_type, ptr_mode,
2574 true),
2575 gnu_expr);
2576 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_expr);
2577 break;
2579 default:
2580 /* This abort means that we have an unimplemented attribute. */
2581 gcc_unreachable ();
2584 /* If this is an attribute where the prefix was unused, force a use of it if
2585 it has a side-effect. But don't do it if the prefix is just an entity
2586 name. However, if an access check is needed, we must do it. See second
2587 example in AARM 11.6(5.e). */
2588 if (prefix_unused
2589 && TREE_SIDE_EFFECTS (gnu_prefix)
2590 && !Is_Entity_Name (gnat_prefix))
2591 gnu_result
2592 = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
2594 *gnu_result_type_p = gnu_result_type;
2595 return gnu_result;
2598 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Case_Statement, to a
2599 GCC tree, which is returned. */
2601 static tree
2602 Case_Statement_to_gnu (Node_Id gnat_node)
2604 tree gnu_result, gnu_expr, gnu_type, gnu_label;
2605 Node_Id gnat_when;
2606 location_t end_locus;
2607 bool may_fallthru = false;
2609 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2610 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2611 gnu_expr = maybe_character_value (gnu_expr);
2612 gnu_type = TREE_TYPE (gnu_expr);
2614 /* We build a SWITCH_EXPR that contains the code with interspersed
2615 CASE_LABEL_EXPRs for each label. */
2616 if (!Sloc_to_locus (End_Location (gnat_node), &end_locus))
2617 end_locus = input_location;
2618 gnu_label = create_artificial_label (end_locus);
2619 start_stmt_group ();
2621 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2622 Present (gnat_when);
2623 gnat_when = Next_Non_Pragma (gnat_when))
2625 bool choices_added_p = false;
2626 Node_Id gnat_choice;
2628 /* First compile all the different case choices for the current WHEN
2629 alternative. */
2630 for (gnat_choice = First (Discrete_Choices (gnat_when));
2631 Present (gnat_choice);
2632 gnat_choice = Next (gnat_choice))
2634 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2635 tree label = create_artificial_label (input_location);
2637 switch (Nkind (gnat_choice))
2639 case N_Range:
2640 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2641 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2642 break;
2644 case N_Subtype_Indication:
2645 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2646 (Constraint (gnat_choice))));
2647 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2648 (Constraint (gnat_choice))));
2649 break;
2651 case N_Identifier:
2652 case N_Expanded_Name:
2653 /* This represents either a subtype range or a static value of
2654 some kind; Ekind says which. */
2655 if (Is_Type (Entity (gnat_choice)))
2657 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2659 gnu_low = TYPE_MIN_VALUE (gnu_type);
2660 gnu_high = TYPE_MAX_VALUE (gnu_type);
2661 break;
2664 /* ... fall through ... */
2666 case N_Character_Literal:
2667 case N_Integer_Literal:
2668 gnu_low = gnat_to_gnu (gnat_choice);
2669 break;
2671 case N_Others_Choice:
2672 break;
2674 default:
2675 gcc_unreachable ();
2678 /* Everything should be folded into constants at this point. */
2679 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
2680 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
2682 if (gnu_low && TREE_TYPE (gnu_low) != gnu_type)
2683 gnu_low = convert (gnu_type, gnu_low);
2684 if (gnu_high && TREE_TYPE (gnu_high) != gnu_type)
2685 gnu_high = convert (gnu_type, gnu_high);
2687 add_stmt_with_node (build_case_label (gnu_low, gnu_high, label),
2688 gnat_choice);
2689 choices_added_p = true;
2692 /* This construct doesn't define a scope so we shouldn't push a binding
2693 level around the statement list. Except that we have always done so
2694 historically and this makes it possible to reduce stack usage. As a
2695 compromise, we keep doing it for case statements, for which this has
2696 never been problematic, but not for case expressions in Ada 2012. */
2697 if (choices_added_p)
2699 const bool is_case_expression
2700 = (Nkind (Parent (gnat_node)) == N_Expression_With_Actions);
2701 tree group
2702 = build_stmt_group (Statements (gnat_when), !is_case_expression);
2703 bool group_may_fallthru = block_may_fallthru (group);
2704 add_stmt (group);
2705 if (group_may_fallthru)
2707 tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2708 SET_EXPR_LOCATION (stmt, end_locus);
2709 add_stmt (stmt);
2710 may_fallthru = true;
2715 /* Now emit a definition of the label the cases branch to, if any. */
2716 if (may_fallthru)
2717 add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2718 gnu_result = build2 (SWITCH_EXPR, gnu_type, gnu_expr, end_stmt_group ());
2720 return gnu_result;
2723 /* Return true if we are in the body of a loop. */
2725 static inline bool
2726 inside_loop_p (void)
2728 return !vec_safe_is_empty (gnu_loop_stack);
2731 /* Find out whether EXPR is a simple additive expression based on the iteration
2732 variable of some enclosing loop in the current function. If so, return the
2733 loop and set *DISP to the displacement and *NEG_P to true if this is for a
2734 subtraction; otherwise, return NULL. */
2736 static struct loop_info_d *
2737 find_loop_for (tree expr, tree *disp, bool *neg_p)
2739 tree var, add, cst;
2740 bool minus_p;
2741 struct loop_info_d *iter = NULL;
2742 unsigned int i;
2744 if (is_simple_additive_expression (expr, &add, &cst, &minus_p))
2746 var = add;
2747 if (disp)
2748 *disp = cst;
2749 if (neg_p)
2750 *neg_p = minus_p;
2752 else
2754 var = expr;
2755 if (disp)
2756 *disp = NULL_TREE;
2757 if (neg_p)
2758 *neg_p = false;
2761 var = remove_conversions (var, false);
2763 if (TREE_CODE (var) != VAR_DECL)
2764 return NULL;
2766 gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0);
2768 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
2769 if (iter->loop_var == var && iter->fndecl == current_function_decl)
2770 break;
2772 return iter;
2775 /* Return the innermost enclosing loop in the current function. */
2777 static struct loop_info_d *
2778 find_loop (void)
2780 struct loop_info_d *iter = NULL;
2781 unsigned int i;
2783 gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0);
2785 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
2786 if (iter->fndecl == current_function_decl)
2787 break;
2789 return iter;
2792 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2793 false, or the maximum value if MAX is true, of TYPE. */
2795 static bool
2796 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2798 tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2800 if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2801 return true;
2803 if (TREE_CODE (val) == NOP_EXPR)
2804 val = (max
2805 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2806 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2808 if (TREE_CODE (val) != INTEGER_CST)
2809 return true;
2811 if (max)
2812 return tree_int_cst_lt (val, min_or_max_val) == 0;
2813 else
2814 return tree_int_cst_lt (min_or_max_val, val) == 0;
2817 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2818 If REVERSE is true, minimum value is taken as maximum value. */
2820 static inline bool
2821 can_equal_min_val_p (tree val, tree type, bool reverse)
2823 return can_equal_min_or_max_val_p (val, type, reverse);
2826 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2827 If REVERSE is true, maximum value is taken as minimum value. */
2829 static inline bool
2830 can_equal_max_val_p (tree val, tree type, bool reverse)
2832 return can_equal_min_or_max_val_p (val, type, !reverse);
2835 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
2836 true if both expressions have been replaced and false otherwise. */
2838 static bool
2839 make_invariant (tree *expr1, tree *expr2)
2841 tree inv_expr1 = gnat_invariant_expr (*expr1);
2842 tree inv_expr2 = gnat_invariant_expr (*expr2);
2844 if (inv_expr1)
2845 *expr1 = inv_expr1;
2847 if (inv_expr2)
2848 *expr2 = inv_expr2;
2850 return inv_expr1 && inv_expr2;
2853 /* Helper function for walk_tree, used by independent_iterations_p below. */
2855 static tree
2856 scan_rhs_r (tree *tp, int *walk_subtrees, void *data)
2858 bitmap *params = (bitmap *)data;
2859 tree t = *tp;
2861 /* No need to walk into types or decls. */
2862 if (IS_TYPE_OR_DECL_P (t))
2863 *walk_subtrees = 0;
2865 if (TREE_CODE (t) == PARM_DECL && bitmap_bit_p (*params, DECL_UID (t)))
2866 return t;
2868 return NULL_TREE;
2871 /* Return true if STMT_LIST generates independent iterations in a loop. */
2873 static bool
2874 independent_iterations_p (tree stmt_list)
2876 tree_stmt_iterator tsi;
2877 bitmap params = BITMAP_GGC_ALLOC();
2878 auto_vec<tree, 16> rhs;
2879 tree iter;
2880 int i;
2882 if (TREE_CODE (stmt_list) == BIND_EXPR)
2883 stmt_list = BIND_EXPR_BODY (stmt_list);
2885 /* Scan the list and return false on anything that is not either a check
2886 or an assignment to a parameter with restricted aliasing. */
2887 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
2889 tree stmt = tsi_stmt (tsi);
2891 switch (TREE_CODE (stmt))
2893 case COND_EXPR:
2895 if (COND_EXPR_ELSE (stmt))
2896 return false;
2897 if (TREE_CODE (COND_EXPR_THEN (stmt)) != CALL_EXPR)
2898 return false;
2899 tree func = get_callee_fndecl (COND_EXPR_THEN (stmt));
2900 if (!(func && TREE_THIS_VOLATILE (func)))
2901 return false;
2902 break;
2905 case MODIFY_EXPR:
2907 tree lhs = TREE_OPERAND (stmt, 0);
2908 while (handled_component_p (lhs))
2909 lhs = TREE_OPERAND (lhs, 0);
2910 if (TREE_CODE (lhs) != INDIRECT_REF)
2911 return false;
2912 lhs = TREE_OPERAND (lhs, 0);
2913 if (!(TREE_CODE (lhs) == PARM_DECL
2914 && DECL_RESTRICTED_ALIASING_P (lhs)))
2915 return false;
2916 bitmap_set_bit (params, DECL_UID (lhs));
2917 rhs.safe_push (TREE_OPERAND (stmt, 1));
2918 break;
2921 default:
2922 return false;
2926 /* At this point we know that the list contains only statements that will
2927 modify parameters with restricted aliasing. Check that the statements
2928 don't at the time read from these parameters. */
2929 FOR_EACH_VEC_ELT (rhs, i, iter)
2930 if (walk_tree_without_duplicates (&iter, scan_rhs_r, &params))
2931 return false;
2933 return true;
2936 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Loop_Statement, to a
2937 GCC tree, which is returned. */
2939 static tree
2940 Loop_Statement_to_gnu (Node_Id gnat_node)
2942 const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2943 struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
2944 tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2945 NULL_TREE, NULL_TREE, NULL_TREE);
2946 tree gnu_loop_label = create_artificial_label (input_location);
2947 tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2948 tree gnu_result;
2950 /* Push the loop_info structure associated with the LOOP_STMT. */
2951 gnu_loop_info->fndecl = current_function_decl;
2952 gnu_loop_info->stmt = gnu_loop_stmt;
2953 vec_safe_push (gnu_loop_stack, gnu_loop_info);
2955 /* Set location information for statement and end label. */
2956 set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2957 Sloc_to_locus (Sloc (End_Label (gnat_node)),
2958 &DECL_SOURCE_LOCATION (gnu_loop_label));
2959 LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2961 /* Set the condition under which the loop must keep going. If we have an
2962 explicit condition, use it to set the location information throughout
2963 the translation of the loop statement to avoid having multiple SLOCs.
2965 For the case "LOOP .... END LOOP;" the condition is always true. */
2966 if (No (gnat_iter_scheme))
2969 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2970 else if (Present (Condition (gnat_iter_scheme)))
2972 LOOP_STMT_COND (gnu_loop_stmt)
2973 = gnat_to_gnu (Condition (gnat_iter_scheme));
2975 set_expr_location_from_node (gnu_loop_stmt, gnat_iter_scheme);
2978 /* Otherwise we have an iteration scheme and the condition is given by the
2979 bounds of the subtype of the iteration variable. */
2980 else
2982 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2983 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2984 Entity_Id gnat_type = Etype (gnat_loop_var);
2985 tree gnu_type = get_unpadded_type (gnat_type);
2986 tree gnu_base_type = maybe_character_type (get_base_type (gnu_type));
2987 tree gnu_one_node = build_int_cst (gnu_base_type, 1);
2988 tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2989 enum tree_code update_code, test_code, shift_code;
2990 bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2992 gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type));
2993 gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type));
2995 /* We must disable modulo reduction for the iteration variable, if any,
2996 in order for the loop comparison to be effective. */
2997 if (reverse)
2999 gnu_first = gnu_high;
3000 gnu_last = gnu_low;
3001 update_code = MINUS_NOMOD_EXPR;
3002 test_code = GE_EXPR;
3003 shift_code = PLUS_NOMOD_EXPR;
3005 else
3007 gnu_first = gnu_low;
3008 gnu_last = gnu_high;
3009 update_code = PLUS_NOMOD_EXPR;
3010 test_code = LE_EXPR;
3011 shift_code = MINUS_NOMOD_EXPR;
3014 /* We use two different strategies to translate the loop, depending on
3015 whether optimization is enabled.
3017 If it is, we generate the canonical loop form expected by the loop
3018 optimizer and the loop vectorizer, which is the do-while form:
3020 ENTRY_COND
3021 loop:
3022 TOP_UPDATE
3023 BODY
3024 BOTTOM_COND
3025 GOTO loop
3027 This avoids an implicit dependency on loop header copying and makes
3028 it possible to turn BOTTOM_COND into an inequality test.
3030 If optimization is disabled, loop header copying doesn't come into
3031 play and we try to generate the loop form with the fewer conditional
3032 branches. First, the default form, which is:
3034 loop:
3035 TOP_COND
3036 BODY
3037 BOTTOM_UPDATE
3038 GOTO loop
3040 It should catch most loops with constant ending point. Then, if we
3041 cannot, we try to generate the shifted form:
3043 loop:
3044 TOP_COND
3045 TOP_UPDATE
3046 BODY
3047 GOTO loop
3049 which should catch loops with constant starting point. Otherwise, if
3050 we cannot, we generate the fallback form:
3052 ENTRY_COND
3053 loop:
3054 BODY
3055 BOTTOM_COND
3056 BOTTOM_UPDATE
3057 GOTO loop
3059 which works in all cases. */
3061 if (optimize && !optimize_debug)
3063 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
3064 overflow. */
3065 if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
3068 /* Otherwise, use the do-while form with the help of a special
3069 induction variable in the unsigned version of the base type
3070 or the unsigned version of the size type, whichever is the
3071 largest, in order to have wrap-around arithmetics for it. */
3072 else
3074 if (TYPE_PRECISION (gnu_base_type)
3075 > TYPE_PRECISION (size_type_node))
3076 gnu_base_type
3077 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1);
3078 else
3079 gnu_base_type = size_type_node;
3081 gnu_first = convert (gnu_base_type, gnu_first);
3082 gnu_last = convert (gnu_base_type, gnu_last);
3083 gnu_one_node = build_int_cst (gnu_base_type, 1);
3084 use_iv = true;
3087 gnu_first
3088 = build_binary_op (shift_code, gnu_base_type, gnu_first,
3089 gnu_one_node);
3090 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
3091 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3093 else
3095 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
3096 if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
3099 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
3100 GNU_LAST-1 does. */
3101 else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
3102 && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
3104 gnu_first
3105 = build_binary_op (shift_code, gnu_base_type, gnu_first,
3106 gnu_one_node);
3107 gnu_last
3108 = build_binary_op (shift_code, gnu_base_type, gnu_last,
3109 gnu_one_node);
3110 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
3113 /* Otherwise, use the fallback form. */
3114 else
3115 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3118 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3119 test but we have to add ENTRY_COND to protect the empty loop. */
3120 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
3122 test_code = NE_EXPR;
3123 gnu_cond_expr
3124 = build3 (COND_EXPR, void_type_node,
3125 build_binary_op (LE_EXPR, boolean_type_node,
3126 gnu_low, gnu_high),
3127 NULL_TREE, alloc_stmt_list ());
3128 set_expr_location_from_node (gnu_cond_expr, gnat_iter_scheme);
3131 /* Open a new nesting level that will surround the loop to declare the
3132 iteration variable. */
3133 start_stmt_group ();
3134 gnat_pushlevel ();
3136 /* If we use the special induction variable, create it and set it to
3137 its initial value. Morever, the regular iteration variable cannot
3138 itself be initialized, lest the initial value wrapped around. */
3139 if (use_iv)
3141 gnu_loop_iv
3142 = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
3143 add_stmt (gnu_stmt);
3144 gnu_first = NULL_TREE;
3146 else
3147 gnu_loop_iv = NULL_TREE;
3149 /* Declare the iteration variable and set it to its initial value. */
3150 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, true);
3151 if (DECL_BY_REF_P (gnu_loop_var))
3152 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
3153 else if (use_iv)
3155 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
3156 SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
3158 gnu_loop_info->loop_var = gnu_loop_var;
3159 gnu_loop_info->low_bound = gnu_low;
3160 gnu_loop_info->high_bound = gnu_high;
3162 /* Do all the arithmetics in the base type. */
3163 gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
3165 /* Set either the top or bottom exit condition. */
3166 if (use_iv)
3167 LOOP_STMT_COND (gnu_loop_stmt)
3168 = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
3169 gnu_last);
3170 else
3171 LOOP_STMT_COND (gnu_loop_stmt)
3172 = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
3173 gnu_last);
3175 /* Set either the top or bottom update statement and give it the source
3176 location of the iteration for better coverage info. */
3177 if (use_iv)
3179 gnu_stmt
3180 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
3181 build_binary_op (update_code, gnu_base_type,
3182 gnu_loop_iv, gnu_one_node));
3183 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3184 append_to_statement_list (gnu_stmt,
3185 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3186 gnu_stmt
3187 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3188 gnu_loop_iv);
3189 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3190 append_to_statement_list (gnu_stmt,
3191 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3193 else
3195 gnu_stmt
3196 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3197 build_binary_op (update_code, gnu_base_type,
3198 gnu_loop_var, gnu_one_node));
3199 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3200 LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
3203 set_expr_location_from_node (gnu_loop_stmt, gnat_iter_scheme);
3206 /* If the loop was named, have the name point to this loop. In this case,
3207 the association is not a DECL node, but the end label of the loop. */
3208 if (Present (Identifier (gnat_node)))
3209 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
3211 /* Make the loop body into its own block, so any allocated storage will be
3212 released every iteration. This is needed for stack allocation. */
3213 LOOP_STMT_BODY (gnu_loop_stmt)
3214 = build_stmt_group (Statements (gnat_node), true);
3215 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
3217 /* If we have an iteration scheme, then we are in a statement group. Add
3218 the LOOP_STMT to it, finish it and make it the "loop". */
3219 if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
3221 /* First, if we have computed invariant conditions for range (or index)
3222 checks applied to the iteration variable, find out whether they can
3223 be evaluated to false at compile time; otherwise, if there are not
3224 too many of them, combine them with the original checks. If loop
3225 unswitching is enabled, do not require the loop bounds to be also
3226 invariant, as their evaluation will still be ahead of the loop. */
3227 if (vec_safe_length (gnu_loop_info->checks) > 0
3228 && (make_invariant (&gnu_low, &gnu_high) || optimize >= 3))
3230 struct range_check_info_d *rci;
3231 unsigned int i, n_remaining_checks = 0;
3233 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3235 tree low_ok, high_ok;
3237 if (rci->low_bound)
3239 tree gnu_adjusted_low = convert (rci->type, gnu_low);
3240 if (rci->disp)
3241 gnu_adjusted_low
3242 = fold_build2 (rci->neg_p ? MINUS_EXPR : PLUS_EXPR,
3243 rci->type, gnu_adjusted_low, rci->disp);
3244 low_ok
3245 = build_binary_op (GE_EXPR, boolean_type_node,
3246 gnu_adjusted_low, rci->low_bound);
3248 else
3249 low_ok = boolean_true_node;
3251 if (rci->high_bound)
3253 tree gnu_adjusted_high = convert (rci->type, gnu_high);
3254 if (rci->disp)
3255 gnu_adjusted_high
3256 = fold_build2 (rci->neg_p ? MINUS_EXPR : PLUS_EXPR,
3257 rci->type, gnu_adjusted_high, rci->disp);
3258 high_ok
3259 = build_binary_op (LE_EXPR, boolean_type_node,
3260 gnu_adjusted_high, rci->high_bound);
3262 else
3263 high_ok = boolean_true_node;
3265 tree range_ok
3266 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
3267 low_ok, high_ok);
3269 rci->invariant_cond
3270 = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
3272 if (rci->invariant_cond == boolean_false_node)
3273 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3274 else
3275 n_remaining_checks++;
3278 /* Note that loop unswitching can only be applied a small number of
3279 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3280 if (IN_RANGE (n_remaining_checks, 1, 3)
3281 && optimize >= 2
3282 && !optimize_size)
3283 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3284 if (rci->invariant_cond != boolean_false_node)
3286 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3288 if (optimize >= 3)
3289 add_stmt_with_node_force (rci->inserted_cond, gnat_node);
3293 /* Second, if we have recorded invariants to be hoisted, emit them. */
3294 if (vec_safe_length (gnu_loop_info->invariants) > 0)
3296 tree *iter;
3297 unsigned int i;
3298 FOR_EACH_VEC_ELT (*gnu_loop_info->invariants, i, iter)
3299 add_stmt_with_node_force (*iter, gnat_node);
3302 /* Third, if loop vectorization is enabled and the iterations of the
3303 loop can easily be proved as independent, mark the loop. */
3304 if (optimize >= 3
3305 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt)))
3306 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
3308 add_stmt (gnu_loop_stmt);
3309 gnat_poplevel ();
3310 gnu_loop_stmt = end_stmt_group ();
3313 /* If we have an outer COND_EXPR, that's our result and this loop is its
3314 "true" statement. Otherwise, the result is the LOOP_STMT. */
3315 if (gnu_cond_expr)
3317 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
3318 TREE_SIDE_EFFECTS (gnu_cond_expr) = 1;
3319 gnu_result = gnu_cond_expr;
3321 else
3322 gnu_result = gnu_loop_stmt;
3324 gnu_loop_stack->pop ();
3326 return gnu_result;
3329 /* This page implements a form of Named Return Value optimization modeled
3330 on the C++ optimization of the same name. The main difference is that
3331 we disregard any semantical considerations when applying it here, the
3332 counterpart being that we don't try to apply it to semantically loaded
3333 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3335 We consider a function body of the following GENERIC form:
3337 return_type R1;
3338 [...]
3339 RETURN_EXPR [<retval> = ...]
3340 [...]
3341 RETURN_EXPR [<retval> = R1]
3342 [...]
3343 return_type Ri;
3344 [...]
3345 RETURN_EXPR [<retval> = ...]
3346 [...]
3347 RETURN_EXPR [<retval> = Ri]
3348 [...]
3350 where the Ri are not addressable and we try to fulfill a simple criterion
3351 that would make it possible to replace one or several Ri variables by the
3352 single RESULT_DECL of the function.
3354 The first observation is that RETURN_EXPRs that don't directly reference
3355 any of the Ri variables on the RHS of their assignment are transparent wrt
3356 the optimization. This is because the Ri variables aren't addressable so
3357 any transformation applied to them doesn't affect the RHS; moreover, the
3358 assignment writes the full <retval> object so existing values are entirely
3359 discarded.
3361 This property can be extended to some forms of RETURN_EXPRs that reference
3362 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3363 case, in particular when function calls are involved.
3365 Therefore the algorithm is as follows:
3367 1. Collect the list of candidates for a Named Return Value (Ri variables
3368 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3369 other expressions on the RHS of such assignments.
3371 2. Prune the members of the first list (candidates) that are referenced
3372 by a member of the second list (expressions).
3374 3. Extract a set of candidates with non-overlapping live ranges from the
3375 first list. These are the Named Return Values.
3377 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3378 Named Return Values in the function with the RESULT_DECL.
3380 If the function returns an unconstrained type, things are a bit different
3381 because the anonymous return object is allocated on the secondary stack
3382 and RESULT_DECL is only a pointer to it. Each return object can be of a
3383 different size and is allocated separately so we need not care about the
3384 addressability and the aforementioned overlapping issues. Therefore, we
3385 don't collect the other expressions and skip step #2 in the algorithm. */
3387 struct nrv_data
3389 bitmap nrv;
3390 tree result;
3391 Node_Id gnat_ret;
3392 hash_set<tree> *visited;
3395 /* Return true if T is a Named Return Value. */
3397 static inline bool
3398 is_nrv_p (bitmap nrv, tree t)
3400 return VAR_P (t) && bitmap_bit_p (nrv, DECL_UID (t));
3403 /* Helper function for walk_tree, used by finalize_nrv below. */
3405 static tree
3406 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
3408 struct nrv_data *dp = (struct nrv_data *)data;
3409 tree t = *tp;
3411 /* No need to walk into types or decls. */
3412 if (IS_TYPE_OR_DECL_P (t))
3413 *walk_subtrees = 0;
3415 if (is_nrv_p (dp->nrv, t))
3416 bitmap_clear_bit (dp->nrv, DECL_UID (t));
3418 return NULL_TREE;
3421 /* Prune Named Return Values in BLOCK and return true if there is still a
3422 Named Return Value in BLOCK or one of its sub-blocks. */
3424 static bool
3425 prune_nrv_in_block (bitmap nrv, tree block)
3427 bool has_nrv = false;
3428 tree t;
3430 /* First recurse on the sub-blocks. */
3431 for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
3432 has_nrv |= prune_nrv_in_block (nrv, t);
3434 /* Then make sure to keep at most one NRV per block. */
3435 for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
3436 if (is_nrv_p (nrv, t))
3438 if (has_nrv)
3439 bitmap_clear_bit (nrv, DECL_UID (t));
3440 else
3441 has_nrv = true;
3444 return has_nrv;
3447 /* Helper function for walk_tree, used by finalize_nrv below. */
3449 static tree
3450 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
3452 struct nrv_data *dp = (struct nrv_data *)data;
3453 tree t = *tp;
3455 /* No need to walk into types. */
3456 if (TYPE_P (t))
3457 *walk_subtrees = 0;
3459 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3460 nop, but differs from using NULL_TREE in that it indicates that we care
3461 about the value of the RESULT_DECL. */
3462 else if (TREE_CODE (t) == RETURN_EXPR
3463 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3465 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3467 /* Strip useless conversions around the return value. */
3468 if (gnat_useless_type_conversion (ret_val))
3469 ret_val = TREE_OPERAND (ret_val, 0);
3471 if (is_nrv_p (dp->nrv, ret_val))
3472 TREE_OPERAND (t, 0) = dp->result;
3475 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3476 if needed. */
3477 else if (TREE_CODE (t) == DECL_EXPR
3478 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3480 tree var = DECL_EXPR_DECL (t), init;
3482 if (DECL_INITIAL (var))
3484 init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
3485 DECL_INITIAL (var));
3486 SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
3487 DECL_INITIAL (var) = NULL_TREE;
3489 else
3490 init = build_empty_stmt (EXPR_LOCATION (t));
3491 *tp = init;
3493 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3494 SET_DECL_VALUE_EXPR (var, dp->result);
3495 DECL_HAS_VALUE_EXPR_P (var) = 1;
3496 /* ??? Kludge to avoid an assertion failure during inlining. */
3497 DECL_SIZE (var) = bitsize_unit_node;
3498 DECL_SIZE_UNIT (var) = size_one_node;
3501 /* And replace all uses of NRVs with the RESULT_DECL. */
3502 else if (is_nrv_p (dp->nrv, t))
3503 *tp = convert (TREE_TYPE (t), dp->result);
3505 /* Avoid walking into the same tree more than once. Unfortunately, we
3506 can't just use walk_tree_without_duplicates because it would only
3507 call us for the first occurrence of NRVs in the function body. */
3508 if (dp->visited->add (*tp))
3509 *walk_subtrees = 0;
3511 return NULL_TREE;
3514 /* Likewise, but used when the function returns an unconstrained type. */
3516 static tree
3517 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
3519 struct nrv_data *dp = (struct nrv_data *)data;
3520 tree t = *tp;
3522 /* No need to walk into types. */
3523 if (TYPE_P (t))
3524 *walk_subtrees = 0;
3526 /* We need to see the DECL_EXPR of NRVs before any other references so we
3527 walk the body of BIND_EXPR before walking its variables. */
3528 else if (TREE_CODE (t) == BIND_EXPR)
3529 walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
3531 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3532 return value built by the allocator instead of the whole construct. */
3533 else if (TREE_CODE (t) == RETURN_EXPR
3534 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3536 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3538 /* This is the construct returned by the allocator. */
3539 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3540 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
3542 tree rhs = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3544 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
3545 ret_val = CONSTRUCTOR_ELT (rhs, 1)->value;
3546 else
3547 ret_val = rhs;
3550 /* Strip useless conversions around the return value. */
3551 if (gnat_useless_type_conversion (ret_val)
3552 || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
3553 ret_val = TREE_OPERAND (ret_val, 0);
3555 /* Strip unpadding around the return value. */
3556 if (TREE_CODE (ret_val) == COMPONENT_REF
3557 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
3558 ret_val = TREE_OPERAND (ret_val, 0);
3560 /* Assign the new return value to the RESULT_DECL. */
3561 if (is_nrv_p (dp->nrv, ret_val))
3562 TREE_OPERAND (TREE_OPERAND (t, 0), 1)
3563 = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
3566 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3567 into a new variable. */
3568 else if (TREE_CODE (t) == DECL_EXPR
3569 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3571 tree saved_current_function_decl = current_function_decl;
3572 tree var = DECL_EXPR_DECL (t);
3573 tree alloc, p_array, new_var, new_ret;
3574 vec<constructor_elt, va_gc> *v;
3575 vec_alloc (v, 2);
3577 /* Create an artificial context to build the allocation. */
3578 current_function_decl = decl_function_context (var);
3579 start_stmt_group ();
3580 gnat_pushlevel ();
3582 /* This will return a COMPOUND_EXPR with the allocation in the first
3583 arm and the final return value in the second arm. */
3584 alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
3585 TREE_TYPE (dp->result),
3586 Procedure_To_Call (dp->gnat_ret),
3587 Storage_Pool (dp->gnat_ret),
3588 Empty, false);
3590 /* The new variable is built as a reference to the allocated space. */
3591 new_var
3592 = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
3593 build_reference_type (TREE_TYPE (var)));
3594 DECL_BY_REFERENCE (new_var) = 1;
3596 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
3598 tree cst = TREE_OPERAND (alloc, 1);
3600 /* The new initial value is a COMPOUND_EXPR with the allocation in
3601 the first arm and the value of P_ARRAY in the second arm. */
3602 DECL_INITIAL (new_var)
3603 = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
3604 TREE_OPERAND (alloc, 0),
3605 CONSTRUCTOR_ELT (cst, 0)->value);
3607 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3608 p_array = TYPE_FIELDS (TREE_TYPE (alloc));
3609 CONSTRUCTOR_APPEND_ELT (v, p_array,
3610 fold_convert (TREE_TYPE (p_array), new_var));
3611 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
3612 CONSTRUCTOR_ELT (cst, 1)->value);
3613 new_ret = build_constructor (TREE_TYPE (alloc), v);
3615 else
3617 /* The new initial value is just the allocation. */
3618 DECL_INITIAL (new_var) = alloc;
3619 new_ret = fold_convert (TREE_TYPE (alloc), new_var);
3622 gnat_pushdecl (new_var, Empty);
3624 /* Destroy the artificial context and insert the new statements. */
3625 gnat_zaplevel ();
3626 *tp = end_stmt_group ();
3627 current_function_decl = saved_current_function_decl;
3629 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3630 DECL_CHAIN (new_var) = DECL_CHAIN (var);
3631 DECL_CHAIN (var) = new_var;
3632 DECL_IGNORED_P (var) = 1;
3634 /* Save the new return value and the dereference of NEW_VAR. */
3635 DECL_INITIAL (var)
3636 = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
3637 build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
3638 /* ??? Kludge to avoid messing up during inlining. */
3639 DECL_CONTEXT (var) = NULL_TREE;
3642 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3643 else if (is_nrv_p (dp->nrv, t))
3644 *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3646 /* Avoid walking into the same tree more than once. Unfortunately, we
3647 can't just use walk_tree_without_duplicates because it would only
3648 call us for the first occurrence of NRVs in the function body. */
3649 if (dp->visited->add (*tp))
3650 *walk_subtrees = 0;
3652 return NULL_TREE;
3655 /* Apply FUNC to all the sub-trees of nested functions in NODE. FUNC is called
3656 with the DATA and the address of each sub-tree. If FUNC returns a non-NULL
3657 value, the traversal is stopped. */
3659 static void
3660 walk_nesting_tree (struct cgraph_node *node, walk_tree_fn func, void *data)
3662 for (node = first_nested_function (node);
3663 node; node = next_nested_function (node))
3665 walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), func, data);
3666 walk_nesting_tree (node, func, data);
3670 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3671 contains the candidates for Named Return Value and OTHER is a list of
3672 the other return values. GNAT_RET is a representative return node. */
3674 static void
3675 finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret)
3677 struct nrv_data data;
3678 walk_tree_fn func;
3679 unsigned int i;
3680 tree iter;
3682 /* We shouldn't be applying the optimization to return types that we aren't
3683 allowed to manipulate freely. */
3684 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3686 /* Prune the candidates that are referenced by other return values. */
3687 data.nrv = nrv;
3688 data.result = NULL_TREE;
3689 data.gnat_ret = Empty;
3690 data.visited = NULL;
3691 FOR_EACH_VEC_SAFE_ELT (other, i, iter)
3692 walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3693 if (bitmap_empty_p (nrv))
3694 return;
3696 /* Prune also the candidates that are referenced by nested functions. */
3697 walk_nesting_tree (cgraph_node::get_create (fndecl), prune_nrv_r, &data);
3698 if (bitmap_empty_p (nrv))
3699 return;
3701 /* Extract a set of NRVs with non-overlapping live ranges. */
3702 if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3703 return;
3705 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3706 data.nrv = nrv;
3707 data.result = DECL_RESULT (fndecl);
3708 data.gnat_ret = gnat_ret;
3709 data.visited = new hash_set<tree>;
3710 if (TYPE_RETURN_BY_DIRECT_REF_P (TREE_TYPE (fndecl)))
3711 func = finalize_nrv_unc_r;
3712 else
3713 func = finalize_nrv_r;
3714 walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3715 delete data.visited;
3718 /* Return true if RET_VAL can be used as a Named Return Value for the
3719 anonymous return object RET_OBJ. */
3721 static bool
3722 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3724 if (TREE_CODE (ret_val) != VAR_DECL)
3725 return false;
3727 if (TREE_THIS_VOLATILE (ret_val))
3728 return false;
3730 if (DECL_CONTEXT (ret_val) != current_function_decl)
3731 return false;
3733 if (TREE_STATIC (ret_val))
3734 return false;
3736 /* For the constrained case, test for addressability. */
3737 if (ret_obj && TREE_ADDRESSABLE (ret_val))
3738 return false;
3740 /* For the constrained case, test for overalignment. */
3741 if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3742 return false;
3744 /* For the unconstrained case, test for bogus initialization. */
3745 if (!ret_obj
3746 && DECL_INITIAL (ret_val)
3747 && TREE_CODE (DECL_INITIAL (ret_val)) == NULL_EXPR)
3748 return false;
3750 return true;
3753 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3754 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3755 around RESULT_OBJ, which may be null in this case. */
3757 static tree
3758 build_return_expr (tree ret_obj, tree ret_val)
3760 tree result_expr;
3762 if (ret_val)
3764 /* The gimplifier explicitly enforces the following invariant:
3766 RETURN_EXPR
3768 INIT_EXPR
3771 RET_OBJ ...
3773 As a consequence, type consistency dictates that we use the type
3774 of the RET_OBJ as the operation type. */
3775 tree operation_type = TREE_TYPE (ret_obj);
3777 /* Convert the right operand to the operation type. Note that this is
3778 the transformation applied in the INIT_EXPR case of build_binary_op,
3779 with the assumption that the type cannot involve a placeholder. */
3780 if (operation_type != TREE_TYPE (ret_val))
3781 ret_val = convert (operation_type, ret_val);
3783 /* We always can use an INIT_EXPR for the return object. */
3784 result_expr = build2 (INIT_EXPR, void_type_node, ret_obj, ret_val);
3786 /* If the function returns an aggregate type, find out whether this is
3787 a candidate for Named Return Value. If so, record it. Otherwise,
3788 if this is an expression of some kind, record it elsewhere. */
3789 if (optimize
3790 && !optimize_debug
3791 && AGGREGATE_TYPE_P (operation_type)
3792 && !TYPE_IS_FAT_POINTER_P (operation_type)
3793 && TYPE_MODE (operation_type) == BLKmode
3794 && aggregate_value_p (operation_type, current_function_decl))
3796 /* Strip useless conversions around the return value. */
3797 if (gnat_useless_type_conversion (ret_val))
3798 ret_val = TREE_OPERAND (ret_val, 0);
3800 /* Now apply the test to the return value. */
3801 if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3803 if (!f_named_ret_val)
3804 f_named_ret_val = BITMAP_GGC_ALLOC ();
3805 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3808 /* Note that we need not care about CONSTRUCTORs here, as they are
3809 totally transparent given the read-compose-write semantics of
3810 assignments from CONSTRUCTORs. */
3811 else if (EXPR_P (ret_val))
3812 vec_safe_push (f_other_ret_val, ret_val);
3815 else
3816 result_expr = ret_obj;
3818 return build1 (RETURN_EXPR, void_type_node, result_expr);
3821 /* Subroutine of gnat_to_gnu to translate the At_End_Proc of GNAT_NODE, an
3822 N_Block_Statement or N_Handled_Sequence_Of_Statements or N_*_Body node.
3824 To invoked the GCC mechanism, we call add_cleanup and when we leave the
3825 group, end_stmt_group will create the TRY_FINALLY_EXPR construct. */
3827 static void
3828 At_End_Proc_to_gnu (Node_Id gnat_node)
3830 tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
3831 Node_Id gnat_end_label;
3833 /* When not optimizing, disable inlining of finalizers as this can
3834 create a more complex CFG in the parent function. */
3835 if (!optimize || optimize_debug)
3836 DECL_DECLARED_INLINE_P (proc_decl) = 0;
3838 /* Retrieve the end label attached to the node, if any. */
3839 if (Nkind (gnat_node) == N_Handled_Sequence_Of_Statements)
3840 gnat_end_label = End_Label (gnat_node);
3841 else if (Present (Handled_Statement_Sequence (gnat_node)))
3842 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
3843 else
3844 gnat_end_label = Empty;
3846 /* If there is no end label attached, we use the location of the At_End
3847 procedure because Expand_Cleanup_Actions might reset the location of
3848 the enclosing construct to that of an inner statement. */
3849 add_cleanup (build_call_n_expr (proc_decl, 0),
3850 Present (gnat_end_label)
3851 ? gnat_end_label : At_End_Proc (gnat_node));
3854 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Subprogram_Body. */
3856 static void
3857 Subprogram_Body_to_gnu (Node_Id gnat_node)
3859 /* The defining identifier for the subprogram body. Note that if a
3860 specification has appeared before for this body, then the identifier
3861 occurring in that specification will also be a defining identifier
3862 and calls to this subprogram will point to that specification. */
3863 Entity_Id gnat_subprog
3864 = (Present (Corresponding_Spec (gnat_node))
3865 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3866 /* The FUNCTION_DECL node corresponding to the defining identifier. */
3867 tree gnu_subprog;
3868 /* Its RESULT_DECL node. */
3869 tree gnu_result_decl;
3870 /* Its FUNCTION_TYPE node. */
3871 tree gnu_subprog_type;
3872 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3873 tree gnu_cico_list;
3874 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3875 tree gnu_return_var_elmt;
3876 /* Its source location. */
3877 location_t locus;
3879 /* If this is a generic subprogram or it has been eliminated, ignore it. */
3880 if (Is_Generic_Subprogram (gnat_subprog) || Is_Eliminated (gnat_subprog))
3881 return;
3883 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3884 the already-elaborated tree node. However, if this subprogram had its
3885 elaboration deferred, we will already have made a tree node for it. So
3886 treat it as not being defined in that case. Such a subprogram cannot
3887 have an address clause or a freeze node, so this test is safe, though it
3888 does disable some otherwise-useful error checking. */
3889 gnu_subprog
3890 = gnat_to_gnu_entity (gnat_subprog, NULL_TREE,
3891 Acts_As_Spec (gnat_node)
3892 && !present_gnu_tree (gnat_subprog));
3893 DECL_FUNCTION_IS_DEF (gnu_subprog) = true;
3894 gnu_result_decl = DECL_RESULT (gnu_subprog);
3895 gnu_subprog_type = TREE_TYPE (gnu_subprog);
3896 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3897 if (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node)
3898 gnu_return_var_elmt = gnu_cico_list;
3899 else
3900 gnu_return_var_elmt = NULL_TREE;
3902 /* If the function returns by invisible reference, make it explicit in the
3903 function body. See gnat_to_gnu_subprog_type for more details. */
3904 if (TREE_ADDRESSABLE (gnu_subprog_type))
3906 TREE_TYPE (gnu_result_decl)
3907 = build_reference_type (TREE_TYPE (gnu_result_decl));
3908 relayout_decl (gnu_result_decl);
3911 /* Set the line number in the decl to correspond to that of the body. */
3912 if (DECL_IGNORED_P (gnu_subprog))
3913 locus = UNKNOWN_LOCATION;
3914 else if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog))
3915 locus = input_location;
3916 DECL_SOURCE_LOCATION (gnu_subprog) = locus;
3918 /* Try to create a bona-fide thunk and hand it over to the middle-end. */
3919 if (Is_Thunk (gnat_subprog)
3920 && !Is_Secondary_Stack_Thunk (gnat_subprog)
3921 && maybe_make_gnu_thunk (gnat_subprog, gnu_subprog))
3922 return;
3924 /* Initialize the information structure for the function. */
3925 allocate_struct_function (gnu_subprog, false);
3926 language_function *gnu_subprog_lang = ggc_cleared_alloc<language_function> ();
3927 DECL_STRUCT_FUNCTION (gnu_subprog)->language = gnu_subprog_lang;
3928 DECL_STRUCT_FUNCTION (gnu_subprog)->function_start_locus = locus;
3929 set_cfun (NULL);
3931 begin_subprog_body (gnu_subprog);
3933 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3934 properly copied out by the return statement. We do this by making a new
3935 block and converting any return into a goto to a label at the end of the
3936 block. */
3937 if (gnu_cico_list)
3939 tree gnu_return_var;
3941 vec_safe_push (gnu_return_label_stack,
3942 create_artificial_label (input_location));
3944 start_stmt_group ();
3945 gnat_pushlevel ();
3947 /* If this is a function with copy-in/copy-out parameters and which does
3948 not return by invisible reference, we also need a variable for the
3949 return value to be placed. */
3950 if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type))
3952 tree gnu_return_type
3953 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3955 gnu_return_var
3956 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3957 gnu_return_type, NULL_TREE,
3958 false, false, false, false, false,
3959 true, false, NULL, gnat_subprog);
3960 TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3962 else
3963 gnu_return_var = NULL_TREE;
3965 vec_safe_push (gnu_return_var_stack, gnu_return_var);
3967 /* See whether there are parameters for which we don't have a GCC tree
3968 yet. These must be Out parameters. Make a VAR_DECL for them and
3969 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3970 We can match up the entries because TYPE_CI_CO_LIST is in the order
3971 of the parameters. */
3972 for (Entity_Id gnat_param = First_Formal_With_Extras (gnat_subprog);
3973 Present (gnat_param);
3974 gnat_param = Next_Formal_With_Extras (gnat_param))
3975 if (!present_gnu_tree (gnat_param))
3977 tree gnu_cico_entry = gnu_cico_list;
3978 tree gnu_decl;
3980 /* Skip any entries that have been already filled in; they must
3981 correspond to In Out parameters. */
3982 while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3983 gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3985 /* Do any needed dereferences for by-ref objects. */
3986 gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, true);
3987 gcc_assert (DECL_P (gnu_decl));
3988 if (DECL_BY_REF_P (gnu_decl))
3989 gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
3991 /* Do any needed references for padded types. */
3992 TREE_VALUE (gnu_cico_entry)
3993 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl);
3996 else
3997 vec_safe_push (gnu_return_label_stack, NULL_TREE);
3999 /* Get a tree corresponding to the code for the subprogram. */
4000 start_stmt_group ();
4001 gnat_pushlevel ();
4003 /* First translate the declarations of the subprogram. */
4004 process_decls (Declarations (gnat_node), Empty, true, true);
4006 /* Then generate the code of the subprogram itself. A return statement will
4007 be present and any Out parameters will be handled there. */
4008 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
4010 /* Process the At_End_Proc, if any. */
4011 if (Present (At_End_Proc (gnat_node)))
4012 At_End_Proc_to_gnu (gnat_node);
4014 gnat_poplevel ();
4015 tree gnu_result = end_stmt_group ();
4017 /* Attempt setting the end_locus of our GCC body tree, typically a BIND_EXPR,
4018 then the end_locus of our GCC subprogram declaration tree. */
4019 set_end_locus_from_node (gnu_result, gnat_node);
4020 set_end_locus_from_node (gnu_subprog, gnat_node);
4022 /* If we populated the parameter attributes cache, we need to make sure that
4023 the cached expressions are evaluated on all the possible paths leading to
4024 their uses. So we force their evaluation on entry of the function. */
4025 vec<parm_attr, va_gc> *cache = gnu_subprog_lang->parm_attr_cache;
4026 if (cache)
4028 struct parm_attr_d *pa;
4029 int i;
4031 start_stmt_group ();
4033 FOR_EACH_VEC_ELT (*cache, i, pa)
4035 if (pa->first)
4036 add_stmt_with_node_force (pa->first, gnat_node);
4037 if (pa->last)
4038 add_stmt_with_node_force (pa->last, gnat_node);
4039 if (pa->length)
4040 add_stmt_with_node_force (pa->length, gnat_node);
4043 add_stmt (gnu_result);
4044 gnu_result = end_stmt_group ();
4046 gnu_subprog_lang->parm_attr_cache = NULL;
4049 /* If we are dealing with a return from an Ada procedure with parameters
4050 passed by copy-in/copy-out, we need to return a record containing the
4051 final values of these parameters. If the list contains only one entry,
4052 return just that entry though.
4054 For a full description of the copy-in/copy-out parameter mechanism, see
4055 the part of the gnat_to_gnu_entity routine dealing with the translation
4056 of subprograms.
4058 We need to make a block that contains the definition of that label and
4059 the copying of the return value. It first contains the function, then
4060 the label and copy statement. */
4061 if (gnu_cico_list)
4063 const Node_Id gnat_end_label
4064 = End_Label (Handled_Statement_Sequence (gnat_node));
4066 gnu_return_var_stack->pop ();
4068 add_stmt (gnu_result);
4069 add_stmt (build1 (LABEL_EXPR, void_type_node,
4070 gnu_return_label_stack->last ()));
4072 /* If this is a function which returns by invisible reference, the
4073 return value has already been dealt with at the return statements,
4074 so we only need to indirectly copy out the parameters. */
4075 if (TREE_ADDRESSABLE (gnu_subprog_type))
4077 tree gnu_ret_deref
4078 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl);
4079 tree t;
4081 gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node);
4083 for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t))
4085 tree gnu_field_deref
4086 = build_component_ref (gnu_ret_deref, TREE_PURPOSE (t), true);
4087 gnu_result = build2 (MODIFY_EXPR, void_type_node,
4088 gnu_field_deref, TREE_VALUE (t));
4089 add_stmt_with_node (gnu_result, gnat_end_label);
4093 /* Otherwise, if this is a procedure or a function which does not return
4094 by invisible reference, we can do a direct block-copy out. */
4095 else
4097 tree gnu_retval;
4099 if (list_length (gnu_cico_list) == 1)
4100 gnu_retval = TREE_VALUE (gnu_cico_list);
4101 else
4102 gnu_retval
4103 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
4104 gnu_cico_list);
4106 gnu_result = build_return_expr (gnu_result_decl, gnu_retval);
4107 add_stmt_with_node (gnu_result, gnat_end_label);
4110 gnat_poplevel ();
4111 gnu_result = end_stmt_group ();
4114 gnu_return_label_stack->pop ();
4116 /* On SEH targets, install an exception handler around the main entry
4117 point to catch unhandled exceptions. */
4118 if (DECL_NAME (gnu_subprog) == main_identifier_node
4119 && targetm_common.except_unwind_info (&global_options) == UI_SEH)
4121 tree t;
4122 tree etype;
4124 t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
4125 1, integer_zero_node);
4126 t = build_call_n_expr (unhandled_except_decl, 1, t);
4128 etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl);
4129 etype = tree_cons (NULL_TREE, etype, NULL_TREE);
4131 t = build2 (CATCH_EXPR, void_type_node, etype, t);
4132 gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result),
4133 gnu_result, t);
4136 end_subprog_body (gnu_result);
4138 /* Finally annotate the parameters and disconnect the trees for parameters
4139 that we have turned into variables since they are now unusable. */
4140 for (Entity_Id gnat_param = First_Formal_With_Extras (gnat_subprog);
4141 Present (gnat_param);
4142 gnat_param = Next_Formal_With_Extras (gnat_param))
4144 tree gnu_param = get_gnu_tree (gnat_param);
4145 bool is_var_decl = VAR_P (gnu_param);
4147 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
4148 DECL_BY_REF_P (gnu_param));
4150 if (is_var_decl)
4151 save_gnu_tree (gnat_param, NULL_TREE, false);
4154 /* Disconnect the variable created for the return value. */
4155 if (gnu_return_var_elmt)
4156 TREE_VALUE (gnu_return_var_elmt) = void_type_node;
4158 /* If the function returns an aggregate type and we have candidates for
4159 a Named Return Value, finalize the optimization. */
4160 if (optimize && !optimize_debug && gnu_subprog_lang->named_ret_val)
4162 finalize_nrv (gnu_subprog,
4163 gnu_subprog_lang->named_ret_val,
4164 gnu_subprog_lang->other_ret_val,
4165 gnu_subprog_lang->gnat_ret);
4166 gnu_subprog_lang->named_ret_val = NULL;
4167 gnu_subprog_lang->other_ret_val = NULL;
4170 /* If this is an inlined external function that has been marked uninlinable,
4171 drop the body and stop there. Otherwise compile the body. */
4172 if (DECL_EXTERNAL (gnu_subprog) && DECL_UNINLINABLE (gnu_subprog))
4173 DECL_SAVED_TREE (gnu_subprog) = NULL_TREE;
4174 else
4175 rest_of_subprog_body_compilation (gnu_subprog);
4178 /* The type of an atomic access. */
4180 typedef enum { NOT_ATOMIC, SIMPLE_ATOMIC, OUTER_ATOMIC } atomic_acces_t;
4182 /* Return true if GNAT_NODE references an Atomic entity. This is modeled on
4183 the Is_Atomic_Object predicate of the front-end, but additionally handles
4184 explicit dereferences. */
4186 static bool
4187 node_is_atomic (Node_Id gnat_node)
4189 Entity_Id gnat_entity;
4191 switch (Nkind (gnat_node))
4193 case N_Identifier:
4194 case N_Expanded_Name:
4195 gnat_entity = Entity (gnat_node);
4196 if (!Is_Object (gnat_entity))
4197 break;
4198 return Is_Atomic (gnat_entity)
4199 || (Is_Atomic (Etype (gnat_entity))
4200 && !simple_constant_p (gnat_entity));
4202 case N_Selected_Component:
4203 return Is_Atomic (Etype (gnat_node))
4204 || Is_Atomic (Entity (Selector_Name (gnat_node)));
4206 case N_Indexed_Component:
4207 return Is_Atomic (Etype (gnat_node))
4208 || Has_Atomic_Components (Etype (Prefix (gnat_node)))
4209 || (Is_Entity_Name (Prefix (gnat_node))
4210 && Has_Atomic_Components (Entity (Prefix (gnat_node))));
4212 case N_Explicit_Dereference:
4213 return Is_Atomic (Etype (gnat_node));
4215 default:
4216 break;
4219 return false;
4222 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. This is
4223 modeled on the Is_Volatile_Full_Access_Object predicate of the front-end,
4224 but additionally handles explicit dereferences. */
4226 static bool
4227 node_is_volatile_full_access (Node_Id gnat_node)
4229 Entity_Id gnat_entity;
4231 switch (Nkind (gnat_node))
4233 case N_Identifier:
4234 case N_Expanded_Name:
4235 gnat_entity = Entity (gnat_node);
4236 if (!Is_Object (gnat_entity))
4237 break;
4238 return Is_Volatile_Full_Access (gnat_entity)
4239 || (Is_Volatile_Full_Access (Etype (gnat_entity))
4240 && !simple_constant_p (gnat_entity));
4242 case N_Selected_Component:
4243 return Is_Volatile_Full_Access (Etype (gnat_node))
4244 || Is_Volatile_Full_Access (Entity (Selector_Name (gnat_node)));
4246 case N_Indexed_Component:
4247 case N_Explicit_Dereference:
4248 return Is_Volatile_Full_Access (Etype (gnat_node));
4250 default:
4251 break;
4254 return false;
4257 /* Return true if GNAT_NODE references a component of a larger object. */
4259 static inline bool
4260 node_is_component (Node_Id gnat_node)
4262 const Node_Kind k = Nkind (gnat_node);
4263 return
4264 (k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice);
4267 /* Compute whether GNAT_NODE requires atomic access and set TYPE to the type
4268 of access and SYNC according to the associated synchronization setting.
4270 We implement 3 different semantics of atomicity in this function:
4272 1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma,
4273 2. the Ada 2022 semantics of the Atomic aspect/pragma,
4274 3. the semantics of the Volatile_Full_Access GNAT aspect/pragma.
4276 They are mutually exclusive and the FE should have rejected conflicts. */
4278 static void
4279 get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync)
4281 Node_Id gnat_parent, gnat_temp;
4282 unsigned char attr_id;
4284 /* First, scan the parent to filter out irrelevant cases. */
4285 gnat_parent = Parent (gnat_node);
4286 switch (Nkind (gnat_parent))
4288 case N_Attribute_Reference:
4289 attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
4290 /* Do not mess up machine code insertions. */
4291 if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
4292 goto not_atomic;
4294 /* Nothing to do if we are the prefix of an attribute, since we do not
4295 want an atomic access for things like 'Size. */
4297 /* ... fall through ... */
4299 case N_Reference:
4300 /* The N_Reference node is like an attribute. */
4301 if (Prefix (gnat_parent) == gnat_node)
4302 goto not_atomic;
4303 break;
4305 case N_Object_Renaming_Declaration:
4306 /* Nothing to do for the identifier in an object renaming declaration,
4307 the renaming itself does not need atomic access. */
4308 goto not_atomic;
4310 default:
4311 break;
4314 /* Now strip any type conversion from GNAT_NODE. */
4315 if (Nkind (gnat_node) == N_Type_Conversion
4316 || Nkind (gnat_node) == N_Unchecked_Type_Conversion)
4317 gnat_node = Expression (gnat_node);
4319 /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
4320 a whole require atomic access (RM C.6(15)). But, starting with Ada 2022,
4321 reads of or writes to a nonatomic subcomponent of the object also require
4322 atomic access (RM C.6(19)). */
4323 if (node_is_atomic (gnat_node))
4325 bool as_a_whole = true;
4327 /* If we are the prefix of the parent, then the access is partial. */
4328 for (gnat_temp = gnat_node, gnat_parent = Parent (gnat_temp);
4329 node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_temp;
4330 gnat_temp = gnat_parent, gnat_parent = Parent (gnat_temp))
4331 if (Ada_Version < Ada_2022 || node_is_atomic (gnat_parent))
4332 goto not_atomic;
4333 else
4334 as_a_whole = false;
4336 /* We consider that partial accesses are not sequential actions and,
4337 therefore, do not require synchronization. */
4338 *type = SIMPLE_ATOMIC;
4339 *sync = as_a_whole ? Atomic_Sync_Required (gnat_node) : false;
4340 return;
4343 /* Look for an outer atomic access of a nonatomic subcomponent. Note that,
4344 for VFA, we do this before looking at the node itself because we need to
4345 access the outermost VFA object atomically, unlike for Atomic where it is
4346 the innermost atomic object (RM C.6(19)). */
4347 for (gnat_temp = gnat_node;
4348 node_is_component (gnat_temp);
4349 gnat_temp = Prefix (gnat_temp))
4350 if ((Ada_Version >= Ada_2022 && node_is_atomic (Prefix (gnat_temp)))
4351 || node_is_volatile_full_access (Prefix (gnat_temp)))
4353 *type = OUTER_ATOMIC;
4354 *sync = false;
4355 return;
4358 /* Unlike Atomic, accessing a VFA object always requires atomic access. */
4359 if (node_is_volatile_full_access (gnat_node))
4361 *type = SIMPLE_ATOMIC;
4362 *sync = false;
4363 return;
4366 not_atomic:
4367 *type = NOT_ATOMIC;
4368 *sync = false;
4371 /* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
4372 according to the associated synchronization setting. */
4374 static inline bool
4375 simple_atomic_access_required_p (Node_Id gnat_node, bool *sync)
4377 atomic_acces_t type;
4378 get_atomic_access (gnat_node, &type, sync);
4379 return type == SIMPLE_ATOMIC;
4382 /* Return the storage model specified by GNAT_NODE, or else Empty. */
4384 static Entity_Id
4385 get_storage_model (Node_Id gnat_node)
4387 if (Nkind (gnat_node) == N_Explicit_Dereference
4388 && Has_Designated_Storage_Model_Aspect (Etype (Prefix (gnat_node))))
4389 return Storage_Model_Object (Etype (Prefix (gnat_node)));
4390 else
4391 return Empty;
4394 /* Compute whether GNAT_NODE requires storage model access and set GNAT_SMO to
4395 the storage model object to be used for it if it does, or else Empty. */
4397 static void
4398 get_storage_model_access (Node_Id gnat_node, Entity_Id *gnat_smo)
4400 const Node_Id gnat_parent = Parent (gnat_node);
4401 *gnat_smo = Empty;
4403 switch (Nkind (gnat_parent))
4405 case N_Attribute_Reference:
4406 /* If the parent is an attribute reference that requires an lvalue and
4407 gnat_node is the Prefix (i.e. not a parameter), we do not need to
4408 actually access any storage. */
4409 if (lvalue_required_for_attribute_p (gnat_parent)
4410 && Prefix (gnat_parent) == gnat_node)
4411 return;
4412 break;
4414 case N_Object_Renaming_Declaration:
4415 /* Nothing to do for the identifier in an object renaming declaration,
4416 the renaming itself does not need storage model access. */
4417 return;
4419 default:
4420 break;
4423 /* If we are the prefix of the parent, then the access is above us. */
4424 if (node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node)
4425 return;
4427 /* Now strip any type conversion from GNAT_NODE. */
4428 if (Nkind (gnat_node) == N_Type_Conversion
4429 || Nkind (gnat_node) == N_Unchecked_Type_Conversion)
4430 gnat_node = Expression (gnat_node);
4432 while (node_is_component (gnat_node))
4433 gnat_node = Prefix (gnat_node);
4435 *gnat_smo = get_storage_model (gnat_node);
4438 /* Return true if GNAT_NODE requires storage model access and, if so, set
4439 GNAT_SMO to the storage model object to be used for it. */
4441 static bool
4442 storage_model_access_required_p (Node_Id gnat_node, Entity_Id *gnat_smo)
4444 get_storage_model_access (gnat_node, gnat_smo);
4445 return Present (*gnat_smo);
4448 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4450 static tree
4451 create_temporary (const char *prefix, tree type)
4453 tree gnu_temp
4454 = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
4455 type, NULL_TREE,
4456 false, false, false, false, false,
4457 true, false, NULL, Empty);
4458 return gnu_temp;
4461 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4462 Put the initialization statement into GNU_INIT_STMT and annotate it with
4463 the SLOC of GNAT_NODE. Return the temporary variable. */
4465 static tree
4466 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
4467 Node_Id gnat_node)
4469 tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
4471 *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
4472 set_expr_location_from_node (*gnu_init_stmt, gnat_node);
4474 return gnu_temp;
4477 /* Return true if TYPE is an array of scalar type. */
4479 static bool
4480 is_array_of_scalar_type (tree type)
4482 if (TREE_CODE (type) != ARRAY_TYPE)
4483 return false;
4485 type = TREE_TYPE (type);
4487 return !AGGREGATE_TYPE_P (type) && !POINTER_TYPE_P (type);
4490 /* Helper function for walk_tree, used by return_slot_opt_for_pure_call_p. */
4492 static tree
4493 find_decls_r (tree *tp, int *walk_subtrees, void *data)
4495 bitmap decls = (bitmap) data;
4497 if (TYPE_P (*tp))
4498 *walk_subtrees = 0;
4500 else if (DECL_P (*tp))
4501 bitmap_set_bit (decls, DECL_UID (*tp));
4503 return NULL_TREE;
4506 /* Return whether the assignment TARGET = CALL can be subject to the return
4507 slot optimization, under the assumption that the called function be pure
4508 in the Ada sense and return an array of scalar type. */
4510 static bool
4511 return_slot_opt_for_pure_call_p (tree target, tree call)
4513 /* Check that the target is a DECL. */
4514 if (!DECL_P (target))
4515 return false;
4517 const bitmap decls = BITMAP_GGC_ALLOC ();
4518 call_expr_arg_iterator iter;
4519 tree arg;
4521 /* Check that all the arguments have either a scalar type (we assume that
4522 this means by-copy passing mechanism) or array of scalar type. */
4523 FOR_EACH_CALL_EXPR_ARG (arg, iter, call)
4525 tree arg_type = TREE_TYPE (arg);
4526 if (TREE_CODE (arg_type) == REFERENCE_TYPE)
4527 arg_type = TREE_TYPE (arg_type);
4529 if (is_array_of_scalar_type (arg_type))
4530 walk_tree_without_duplicates (&arg, find_decls_r, decls);
4532 else if (AGGREGATE_TYPE_P (arg_type) || POINTER_TYPE_P (arg_type))
4533 return false;
4536 /* Check that the target is not referenced by the non-scalar arguments. */
4537 return !bitmap_bit_p (decls, DECL_UID (target));
4540 /* Elaborate types referenced in the profile (FIRST_FORMAL, RESULT_TYPE). */
4542 static void
4543 elaborate_profile (Entity_Id first_formal, Entity_Id result_type)
4545 Entity_Id formal;
4547 for (formal = first_formal;
4548 Present (formal);
4549 formal = Next_Formal_With_Extras (formal))
4550 (void) gnat_to_gnu_type (Etype (formal));
4552 if (Present (result_type) && Ekind (result_type) != E_Void)
4553 (void) gnat_to_gnu_type (result_type);
4556 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Function_Call
4557 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4558 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4559 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4560 N_Assignment_Statement and the result is to be placed into that object.
4561 ATOMIC_ACCESS is the type of atomic access to be used for the assignment
4562 to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment
4563 to GNU_TARGET requires atomic synchronization. GNAT_SMO is the storage
4564 model object to be used for the assignment to GNU_TARGET or Empty if there
4565 is none. */
4567 static tree
4568 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
4569 atomic_acces_t atomic_access, bool atomic_sync, Entity_Id gnat_smo)
4571 const bool function_call = (Nkind (gnat_node) == N_Function_Call);
4572 const bool returning_value = (function_call && !gnu_target);
4573 /* The GCC node corresponding to the GNAT subprogram name. This can either
4574 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4575 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4576 subprogram. */
4577 const Node_Id gnat_subprog = Name (gnat_node);
4578 tree gnu_subprog = gnat_to_gnu (gnat_subprog);
4579 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4580 tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
4581 /* The return type of the FUNCTION_TYPE. */
4582 tree gnu_result_type;;
4583 const bool frontend_builtin
4584 = (TREE_CODE (gnu_subprog) == FUNCTION_DECL
4585 && DECL_BUILT_IN_CLASS (gnu_subprog) == BUILT_IN_FRONTEND);
4586 auto_vec<tree, 16> gnu_actual_vec;
4587 tree gnu_name_list = NULL_TREE;
4588 tree gnu_stmt_list = NULL_TREE;
4589 tree gnu_after_list = NULL_TREE;
4590 tree gnu_retval = NULL_TREE;
4591 tree gnu_call, gnu_result;
4592 bool went_into_elab_proc;
4593 bool pushed_binding_level;
4594 bool variadic;
4595 bool by_descriptor;
4596 Entity_Id gnat_formal;
4597 Entity_Id gnat_result_type;
4598 Node_Id gnat_actual;
4599 atomic_acces_t aa_type;
4600 bool aa_sync;
4602 /* The only way we can make a call via an access type is if GNAT_NAME is an
4603 explicit dereference. In that case, get the list of formal args from the
4604 type the access type is pointing to. Otherwise, get the formals from the
4605 entity being called. */
4606 if (Nkind (gnat_subprog) == N_Explicit_Dereference)
4608 const Entity_Id gnat_prefix_type
4609 = Underlying_Type (Etype (Prefix (gnat_subprog)));
4611 gnat_formal = First_Formal_With_Extras (Etype (gnat_subprog));
4612 gnat_result_type = Etype (Etype (gnat_subprog));
4613 variadic = IN (Convention (gnat_prefix_type), Convention_C_Variadic);
4615 /* If the access type doesn't require foreign-compatible representation,
4616 be prepared for descriptors. */
4617 by_descriptor
4618 = targetm.calls.custom_function_descriptors > 0
4619 && Can_Use_Internal_Rep (gnat_prefix_type);
4622 else if (Nkind (gnat_subprog) == N_Attribute_Reference)
4624 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4625 gnat_formal = Empty;
4626 gnat_result_type = Empty;
4627 variadic = false;
4628 by_descriptor = false;
4631 else
4633 gcc_checking_assert (Is_Entity_Name (gnat_subprog));
4635 gnat_formal = First_Formal_With_Extras (Entity (gnat_subprog));
4636 gnat_result_type = Etype (Entity_Id (gnat_subprog));
4637 variadic = IN (Convention (Entity (gnat_subprog)), Convention_C_Variadic);
4638 by_descriptor = false;
4640 /* If we are calling a stubbed function, then raise Program_Error, but
4641 elaborate all our args first. */
4642 if (Convention (Entity (gnat_subprog)) == Convention_Stubbed)
4644 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
4645 gnat_node, N_Raise_Program_Error);
4647 for (gnat_actual = First_Actual (gnat_node);
4648 Present (gnat_actual);
4649 gnat_actual = Next_Actual (gnat_actual))
4650 add_stmt (gnat_to_gnu (gnat_actual));
4652 if (returning_value)
4654 gnu_result_type = TREE_TYPE (gnu_subprog_type);
4655 *gnu_result_type_p = gnu_result_type;
4656 return build1 (NULL_EXPR, gnu_result_type, call_expr);
4659 return call_expr;
4663 /* We must elaborate the entire profile now because, if it references types
4664 that were initially incomplete,, their elaboration changes the contents
4665 of GNU_SUBPROG_TYPE and, in particular, may change the result type. */
4666 elaborate_profile (gnat_formal, gnat_result_type);
4668 gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type));
4669 gnu_result_type = TREE_TYPE (gnu_subprog_type);
4671 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL)
4673 /* For a call to a nested function, check the inlining status. */
4674 if (decl_function_context (gnu_subprog))
4675 check_inlining_for_nested_subprog (gnu_subprog);
4677 /* For a recursive call, avoid explosion due to recursive inlining. */
4678 if (gnu_subprog == current_function_decl)
4679 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog) = 0;
4682 /* The lifetime of the temporaries created for the call ends right after the
4683 return value is copied, so we can give them the scope of the elaboration
4684 routine at top level. */
4685 if (!current_function_decl)
4687 current_function_decl = get_elaboration_procedure ();
4688 went_into_elab_proc = true;
4690 else
4691 went_into_elab_proc = false;
4693 /* First, create the temporary for the return value when:
4695 1. There is no target and the function has copy-in/copy-out parameters,
4696 because we need to preserve the return value before copying back the
4697 parameters.
4699 2. There is no target and the call is made for neither the declaration
4700 of an object (regular or renaming), nor a return statement, nor an
4701 allocator, nor an aggregate, and the return type has variable size
4702 because in this case the gimplifier cannot create the temporary, or
4703 more generally is an aggregate type, because the gimplifier would
4704 create the temporary in the outermost scope instead of locally here.
4705 But there is an exception for an allocator of unconstrained record
4706 type with default discriminant because we allocate the actual size
4707 in this case, unlike in the other cases, so we need a temporary to
4708 fetch the discriminant and we create it here.
4710 3. There is a target and it is a slice or an array with fixed size,
4711 and the return type has variable size, because the gimplifier
4712 doesn't handle these cases.
4714 4. There is a target which is a bit-field and the function returns an
4715 unconstrained record type with default discriminant, because the
4716 return may copy more data than the bit-field can contain.
4718 5. There is a target which needs to be accessed with a storage model.
4720 6. There is no target and we have misaligned In Out or Out parameters
4721 passed by reference, because we need to preserve the return value
4722 before copying back the parameters. However, in this case, we'll
4723 defer creating the temporary, see below.
4725 This must be done before we push a binding level around the call, since
4726 we will pop it before copying the return value. */
4727 if (function_call
4728 && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
4729 || (!gnu_target
4730 && Nkind (Parent (gnat_node)) != N_Object_Declaration
4731 && Nkind (Parent (gnat_node)) != N_Object_Renaming_Declaration
4732 && Nkind (Parent (gnat_node)) != N_Simple_Return_Statement
4733 && (!(Nkind (Parent (gnat_node)) == N_Qualified_Expression
4734 && Nkind (Parent (Parent (gnat_node))) == N_Allocator)
4735 || type_is_padding_self_referential (gnu_result_type))
4736 && Nkind (Parent (gnat_node)) != N_Aggregate
4737 && AGGREGATE_TYPE_P (gnu_result_type)
4738 && !TYPE_IS_FAT_POINTER_P (gnu_result_type))
4739 || (gnu_target
4740 && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
4741 || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
4742 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
4743 == INTEGER_CST))
4744 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
4745 || (gnu_target
4746 && TREE_CODE (gnu_target) == COMPONENT_REF
4747 && DECL_BIT_FIELD (TREE_OPERAND (gnu_target, 1))
4748 && DECL_SIZE (TREE_OPERAND (gnu_target, 1))
4749 != TYPE_SIZE (TREE_TYPE (gnu_target))
4750 && type_is_padding_self_referential (gnu_result_type))
4751 || (gnu_target
4752 && Present (gnat_smo)
4753 && Present (Storage_Model_Copy_To (gnat_smo)))))
4755 gnu_retval = create_temporary ("R", gnu_result_type);
4756 DECL_RETURN_VALUE_P (gnu_retval) = 1;
4759 /* If we don't need a value or have already created it, push a binding level
4760 around the call. This will narrow the lifetime of the temporaries we may
4761 need to make when translating the parameters as much as possible. */
4762 if (!returning_value || gnu_retval)
4764 start_stmt_group ();
4765 gnat_pushlevel ();
4766 pushed_binding_level = true;
4768 else
4769 pushed_binding_level = false;
4771 /* Create the list of the actual parameters as GCC expects it, namely a
4772 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4773 is an expression and the TREE_PURPOSE field is null. But skip Out
4774 parameters not passed by reference and that need not be copied in. */
4775 for (gnat_actual = First_Actual (gnat_node);
4776 Present (gnat_actual);
4777 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4778 gnat_actual = Next_Actual (gnat_actual))
4780 Entity_Id gnat_formal_type = Etype (gnat_formal);
4781 tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
4782 tree gnu_formal = present_gnu_tree (gnat_formal)
4783 ? get_gnu_tree (gnat_formal) : NULL_TREE;
4784 const bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
4785 const bool is_true_formal_parm
4786 = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
4787 const bool is_by_ref_formal_parm
4788 = is_true_formal_parm
4789 && (DECL_BY_REF_P (gnu_formal)
4790 || DECL_BY_COMPONENT_PTR_P (gnu_formal));
4791 /* In the In Out or Out case, we must suppress conversions that yield
4792 an lvalue but can nevertheless cause the creation of a temporary,
4793 because we need the real object in this case, either to pass its
4794 address if it's passed by reference or as target of the back copy
4795 done after the call if it uses the copy-in/copy-out mechanism.
4796 We do it in the In case too, except for an unchecked conversion
4797 to an elementary type or a constrained composite type because it
4798 alone can cause the actual to be misaligned and the addressability
4799 test is applied to the real object. */
4800 const bool suppress_type_conversion
4801 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
4802 && (!in_param
4803 || !is_by_ref_formal_parm
4804 || (Is_Composite_Type (Underlying_Type (gnat_formal_type))
4805 && !Is_Constrained (Underlying_Type (gnat_formal_type)))))
4806 || (Nkind (gnat_actual) == N_Type_Conversion
4807 && Is_Composite_Type (Underlying_Type (gnat_formal_type))));
4808 Node_Id gnat_name = suppress_type_conversion
4809 ? Expression (gnat_actual) : gnat_actual;
4810 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
4812 /* If it's possible we may need to use this expression twice, make sure
4813 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4814 to force side-effects before the call. */
4815 if (!in_param && !is_by_ref_formal_parm)
4817 tree init = NULL_TREE;
4818 gnu_name = gnat_stabilize_reference (gnu_name, true, &init);
4819 if (init)
4820 gnu_name
4821 = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
4824 /* If we are passing a non-addressable parameter by reference, pass the
4825 address of a copy. In the In Out or Out case, set up to copy back
4826 out after the call. */
4827 if (is_by_ref_formal_parm
4828 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
4829 && !addressable_p (gnu_name, gnu_name_type))
4831 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
4833 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4834 but sort of an instantiation for them. */
4835 if (TREE_CODE (remove_conversions (gnu_name, true)) == CONSTRUCTOR)
4838 /* If the formal is passed by reference, a copy is not allowed. */
4839 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type)
4840 || Is_Aliased (gnat_formal))
4841 post_error ("misaligned actual cannot be passed by reference",
4842 gnat_actual);
4844 /* If the mechanism was forced to by-ref, a copy is not allowed but
4845 we issue only a warning because this case is not strict Ada. */
4846 else if (DECL_FORCED_BY_REF_P (gnu_formal))
4847 post_error ("misaligned actual cannot be passed by reference??",
4848 gnat_actual);
4850 /* If the actual type of the object is already the nominal type,
4851 we have nothing to do, except if the size is self-referential
4852 in which case we'll remove the unpadding below. */
4853 if (TREE_TYPE (gnu_name) == gnu_name_type
4854 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
4857 /* Otherwise remove the unpadding from all the objects. */
4858 else if (TREE_CODE (gnu_name) == COMPONENT_REF
4859 && TYPE_IS_PADDING_P
4860 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
4861 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
4863 /* Otherwise convert to the nominal type of the object if needed.
4864 There are several cases in which we need to make the temporary
4865 using this type instead of the actual type of the object when
4866 they are distinct, because the expectations of the callee would
4867 otherwise not be met:
4868 - if it's a justified modular type,
4869 - if the actual type is a smaller form of it,
4870 - if it's a smaller form of the actual type. */
4871 else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
4872 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
4873 || smaller_form_type_p (TREE_TYPE (gnu_name),
4874 gnu_name_type)))
4875 || (INTEGRAL_TYPE_P (gnu_name_type)
4876 && smaller_form_type_p (gnu_name_type,
4877 TREE_TYPE (gnu_name))))
4878 gnu_name = convert (gnu_name_type, gnu_name);
4880 /* If this is an In Out or Out parameter and we're returning a value,
4881 we need to create a temporary for the return value because we must
4882 preserve it before copying back at the very end. */
4883 if (!in_param && returning_value && !gnu_retval)
4885 gnu_retval = create_temporary ("R", gnu_result_type);
4886 DECL_RETURN_VALUE_P (gnu_retval) = 1;
4889 /* If we haven't pushed a binding level, push it now. This will
4890 narrow the lifetime of the temporary we are about to make as
4891 much as possible. */
4892 if (!pushed_binding_level && (!returning_value || gnu_retval))
4894 start_stmt_group ();
4895 gnat_pushlevel ();
4896 pushed_binding_level = true;
4899 /* Create an explicit temporary holding the copy. */
4901 /* Do not initialize it for the _Init parameter of an initialization
4902 procedure since no data is meant to be passed in. */
4903 if (Ekind (gnat_formal) == E_Out_Parameter
4904 && Is_Entity_Name (gnat_subprog)
4905 && Is_Init_Proc (Entity (gnat_subprog)))
4906 gnu_name = gnu_temp = create_temporary ("A", TREE_TYPE (gnu_name));
4908 /* Initialize it on the fly like for an implicit temporary in the
4909 other cases, as we don't necessarily have a statement list. */
4910 else
4912 gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt,
4913 gnat_actual);
4914 gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
4915 gnu_temp);
4918 /* Set up to move the copy back to the original if needed. */
4919 if (!in_param)
4921 /* If the original is a COND_EXPR whose first arm isn't meant to
4922 be further used, just deal with the second arm. This is very
4923 likely the conditional expression built for a check. */
4924 if (TREE_CODE (gnu_orig) == COND_EXPR
4925 && TREE_CODE (TREE_OPERAND (gnu_orig, 1)) == COMPOUND_EXPR
4926 && integer_zerop
4927 (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
4928 gnu_orig = TREE_OPERAND (gnu_orig, 2);
4930 gnu_stmt
4931 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
4932 set_expr_location_from_node (gnu_stmt, gnat_node);
4934 append_to_statement_list (gnu_stmt, &gnu_after_list);
4938 /* Start from the real object and build the actual. */
4939 tree gnu_actual = gnu_name;
4941 /* If atomic access is required for an In or In Out actual parameter,
4942 build the atomic load. */
4943 if (is_true_formal_parm
4944 && !is_by_ref_formal_parm
4945 && Ekind (gnat_formal) != E_Out_Parameter
4946 && simple_atomic_access_required_p (gnat_actual, &aa_sync))
4947 gnu_actual = build_atomic_load (gnu_actual, aa_sync);
4949 /* If this was a procedure call, we may not have removed any padding.
4950 So do it here for the part we will use as an input, if any. */
4951 if (Ekind (gnat_formal) != E_Out_Parameter
4952 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4953 gnu_actual
4954 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
4956 /* Put back the conversion we suppressed above in the computation of the
4957 real object. And even if we didn't suppress any conversion there, we
4958 may have suppressed a conversion to the Etype of the actual earlier,
4959 since the parent is a procedure call, so put it back here. Note that
4960 we might have a dummy type here if the actual is the dereference of a
4961 pointer to it, but that's OK when the formal is passed by reference.
4962 We also do not put back a conversion between an actual and a formal
4963 that are unconstrained array types to avoid creating local bounds. */
4964 tree gnu_actual_type = get_unpadded_type (Etype (gnat_actual));
4965 if (TYPE_IS_DUMMY_P (gnu_actual_type))
4966 gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal));
4967 else if (suppress_type_conversion
4968 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4969 gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual,
4970 No_Truncation (gnat_actual));
4971 else if ((TREE_CODE (TREE_TYPE (gnu_actual)) == UNCONSTRAINED_ARRAY_TYPE
4972 || (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
4973 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))))
4974 && TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4976 else
4977 gnu_actual = convert (gnu_actual_type, gnu_actual);
4979 gigi_checking_assert (!Do_Range_Check (gnat_actual));
4981 /* First see if the parameter is passed by reference. */
4982 if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
4984 if (!in_param)
4986 /* In Out or Out parameters passed by reference don't use the
4987 copy-in/copy-out mechanism so the address of the real object
4988 must be passed to the function. */
4989 gnu_actual = gnu_name;
4991 /* If we have a padded type, be sure we've removed padding. */
4992 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4993 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
4994 gnu_actual);
4996 /* If we have the constructed subtype of an aliased object
4997 with an unconstrained nominal subtype, the type of the
4998 actual includes the template, although it is formally
4999 constrained. So we need to convert it back to the real
5000 constructed subtype to retrieve the constrained part
5001 and takes its address. */
5002 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
5003 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
5004 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
5005 && Is_Array_Type (Underlying_Type (Etype (gnat_actual))))
5006 gnu_actual = convert (gnu_actual_type, gnu_actual);
5009 /* There is no need to convert the actual to the formal's type before
5010 taking its address. The only exception is for unconstrained array
5011 types because of the way we build fat pointers. */
5012 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
5014 /* Put back the conversion we suppressed above for In Out or Out
5015 parameters, since it may set the bounds of the actual. */
5016 if (!in_param && suppress_type_conversion)
5017 gnu_actual = convert (gnu_actual_type, gnu_actual);
5018 gnu_actual = convert (gnu_formal_type, gnu_actual);
5021 /* Take the address of the object and convert to the proper pointer
5022 type. */
5023 gnu_formal_type = TREE_TYPE (gnu_formal);
5024 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
5027 /* Then see if the parameter is an array passed to a foreign convention
5028 subprogram. */
5029 else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
5031 gnu_actual = maybe_padded_object (gnu_actual);
5032 gnu_actual = maybe_unconstrained_array (gnu_actual);
5034 /* Take the address of the object and convert to the proper pointer
5035 type. We'd like to actually compute the address of the beginning
5036 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
5037 possibility that the ARRAY_REF might return a constant and we'd be
5038 getting the wrong address. Neither approach is exactly correct,
5039 but this is the most likely to work in all cases. */
5040 gnu_formal_type = TREE_TYPE (gnu_formal);
5041 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
5044 /* Then see if the parameter is passed by copy. */
5045 else if (is_true_formal_parm)
5047 if (!in_param)
5048 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
5050 gnu_actual = convert (gnu_formal_type, gnu_actual);
5052 /* If this is a front-end built-in function, there is no need to
5053 convert to the type used to pass the argument. */
5054 if (!frontend_builtin)
5055 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
5058 /* Then see if this is an unnamed parameter in a variadic C function. */
5059 else if (variadic)
5061 /* This is based on the processing done in gnat_to_gnu_param, but
5062 we expect the mechanism to be set in (almost) all cases. */
5063 const Mechanism_Type mech = Mechanism (gnat_formal);
5065 /* Strip off possible padding type. */
5066 if (TYPE_IS_PADDING_P (gnu_formal_type))
5067 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
5069 /* Arrays are passed as pointers to element type. First check for
5070 unconstrained array and get the underlying array. */
5071 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
5072 gnu_formal_type
5073 = TREE_TYPE
5074 (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type))));
5076 /* Arrays are passed as pointers to element type. */
5077 if (mech != By_Copy && TREE_CODE (gnu_formal_type) == ARRAY_TYPE)
5079 gnu_actual = maybe_padded_object (gnu_actual);
5080 gnu_actual = maybe_unconstrained_array (gnu_actual);
5082 /* Strip off any multi-dimensional entries, then strip
5083 off the last array to get the component type. */
5084 while (TREE_CODE (TREE_TYPE (gnu_formal_type)) == ARRAY_TYPE
5085 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type)))
5086 gnu_formal_type = TREE_TYPE (gnu_formal_type);
5088 gnu_formal_type = TREE_TYPE (gnu_formal_type);
5089 gnu_formal_type = build_pointer_type (gnu_formal_type);
5090 gnu_actual
5091 = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
5094 /* Fat pointers are passed as thin pointers. */
5095 else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type))
5096 gnu_formal_type
5097 = make_type_from_size (gnu_formal_type,
5098 size_int (POINTER_SIZE), 0);
5100 /* If we were requested or muss pass by reference, do so.
5101 If we were requested to pass by copy, do so.
5102 Otherwise, pass In Out or Out parameters or aggregates by
5103 reference. */
5104 else if (mech == By_Reference
5105 || must_pass_by_ref (gnu_formal_type)
5106 || (mech != By_Copy
5107 && (!in_param || AGGREGATE_TYPE_P (gnu_formal_type))))
5109 gnu_formal_type = build_reference_type (gnu_formal_type);
5110 gnu_actual
5111 = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
5114 /* Otherwise pass by copy after applying default C promotions. */
5115 else
5117 if (INTEGRAL_TYPE_P (gnu_formal_type)
5118 && TYPE_PRECISION (gnu_formal_type)
5119 < TYPE_PRECISION (integer_type_node))
5120 gnu_formal_type = integer_type_node;
5122 else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type)
5123 && TYPE_PRECISION (gnu_formal_type)
5124 < TYPE_PRECISION (double_type_node))
5125 gnu_formal_type = double_type_node;
5128 gnu_actual = convert (gnu_formal_type, gnu_actual);
5131 /* If we didn't create a PARM_DECL for the formal, this means that
5132 it is an Out parameter not passed by reference and that need not
5133 be copied in. In this case, the value of the actual need not be
5134 read. However, we still need to make sure that its side-effects
5135 are evaluated before the call, so we evaluate its address. */
5136 else
5138 if (!in_param)
5139 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
5141 if (TREE_SIDE_EFFECTS (gnu_name))
5143 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
5144 append_to_statement_list (addr, &gnu_stmt_list);
5147 continue;
5150 gnu_actual_vec.safe_push (gnu_actual);
5153 if (frontend_builtin)
5155 tree pred_cst = build_int_cst (integer_type_node, PRED_BUILTIN_EXPECT);
5156 enum internal_fn icode = IFN_BUILTIN_EXPECT;
5158 switch (DECL_FE_FUNCTION_CODE (gnu_subprog))
5160 case BUILT_IN_EXPECT:
5161 break;
5162 case BUILT_IN_LIKELY:
5163 gnu_actual_vec.safe_push (boolean_true_node);
5164 break;
5165 case BUILT_IN_UNLIKELY:
5166 gnu_actual_vec.safe_push (boolean_false_node);
5167 break;
5168 default:
5169 gcc_unreachable ();
5172 gnu_actual_vec.safe_push (pred_cst);
5174 gnu_call
5175 = build_call_expr_internal_loc_array (UNKNOWN_LOCATION,
5176 icode,
5177 gnu_result_type,
5178 gnu_actual_vec.length (),
5179 gnu_actual_vec.begin ());
5181 else
5183 gnu_call
5184 = build_call_array_loc (UNKNOWN_LOCATION,
5185 gnu_result_type,
5186 build_unary_op (ADDR_EXPR, NULL_TREE,
5187 gnu_subprog),
5188 gnu_actual_vec.length (),
5189 gnu_actual_vec.begin ());
5190 CALL_EXPR_BY_DESCRIPTOR (gnu_call) = by_descriptor;
5193 set_expr_location_from_node (gnu_call, gnat_node);
5195 /* If we have created a temporary for the return value, initialize it. */
5196 if (gnu_retval)
5198 tree gnu_stmt
5199 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
5200 set_expr_location_from_node (gnu_stmt, gnat_node);
5201 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
5202 gnu_call = gnu_retval;
5205 /* If this is a subprogram with copy-in/copy-out parameters, we need to
5206 unpack the valued returned from the function into the In Out or Out
5207 parameters. We deal with the function return (if this is an Ada
5208 function) below. */
5209 if (TYPE_CI_CO_LIST (gnu_subprog_type))
5211 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
5212 copy-out parameters. */
5213 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
5214 const int length = list_length (gnu_cico_list);
5216 /* The call sequence must contain one and only one call, even though the
5217 function is pure. Save the result into a temporary if needed. */
5218 if (length > 1)
5220 if (!gnu_retval)
5222 tree gnu_stmt;
5223 gnu_call
5224 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
5225 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
5228 gnu_name_list = nreverse (gnu_name_list);
5231 /* The first entry is for the actual return value if this is a
5232 function, so skip it. */
5233 if (function_call)
5234 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
5236 if (Nkind (gnat_subprog) == N_Explicit_Dereference)
5237 gnat_formal = First_Formal_With_Extras (Etype (gnat_subprog));
5238 else
5239 gnat_formal = First_Formal_With_Extras (Entity (gnat_subprog));
5241 for (gnat_actual = First_Actual (gnat_node);
5242 Present (gnat_actual);
5243 gnat_formal = Next_Formal_With_Extras (gnat_formal),
5244 gnat_actual = Next_Actual (gnat_actual))
5245 /* If we are dealing with a copy-in/copy-out parameter, we must
5246 retrieve its value from the record returned in the call. */
5247 if (!(present_gnu_tree (gnat_formal)
5248 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
5249 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
5250 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))))
5251 && Ekind (gnat_formal) != E_In_Parameter)
5253 /* Get the value to assign to this In Out or Out parameter. It is
5254 either the result of the function if there is only a single such
5255 parameter or the appropriate field from the record returned. */
5256 tree gnu_result
5257 = length == 1
5258 ? gnu_call
5259 : build_component_ref (gnu_call, TREE_PURPOSE (gnu_cico_list),
5260 false);
5262 /* If the actual is a conversion, get the inner expression, which
5263 will be the real destination, and convert the result to the
5264 type of the actual parameter. */
5265 tree gnu_actual
5266 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
5268 /* If the result is padded, remove the padding. */
5269 gnu_result = maybe_padded_object (gnu_result);
5271 /* If the actual is a type conversion, the real target object is
5272 denoted by the inner Expression and we need to convert the
5273 result to the associated type.
5274 We also need to convert our gnu assignment target to this type
5275 if the corresponding GNU_NAME was constructed from the GNAT
5276 conversion node and not from the inner Expression. */
5277 if (Nkind (gnat_actual) == N_Type_Conversion)
5279 const Node_Id gnat_expr = Expression (gnat_actual);
5281 gigi_checking_assert (!Do_Range_Check (gnat_expr));
5283 gnu_result
5284 = convert_with_check (Etype (gnat_expr), gnu_result,
5285 Do_Overflow_Check (gnat_actual),
5286 Float_Truncate (gnat_actual),
5287 gnat_actual);
5289 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
5290 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
5293 /* Unchecked conversions as actuals for Out parameters are not
5294 allowed in user code because they are not variables, but do
5295 occur in front-end expansions. The associated GNU_NAME is
5296 always obtained from the inner expression in such cases. */
5297 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
5298 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
5299 gnu_result,
5300 No_Truncation (gnat_actual));
5301 else
5303 gigi_checking_assert (!Do_Range_Check (gnat_actual));
5305 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
5306 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
5307 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
5310 get_atomic_access (gnat_actual, &aa_type, &aa_sync);
5312 /* If an outer atomic access is required for an actual parameter,
5313 build the load-modify-store sequence. */
5314 if (aa_type == OUTER_ATOMIC)
5315 gnu_result
5316 = build_load_modify_store (gnu_actual, gnu_result, gnat_node);
5318 /* Or else, if a simple atomic access is required, build the atomic
5319 store. */
5320 else if (aa_type == SIMPLE_ATOMIC)
5321 gnu_result
5322 = build_atomic_store (gnu_actual, gnu_result, aa_sync);
5324 /* Otherwise build a regular assignment. */
5325 else
5326 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
5327 gnu_actual, gnu_result);
5329 if (EXPR_P (gnu_result))
5330 set_expr_location_from_node (gnu_result, gnat_node);
5331 append_to_statement_list (gnu_result, &gnu_stmt_list);
5332 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
5333 gnu_name_list = TREE_CHAIN (gnu_name_list);
5337 /* If this is a function call, the result is the call expression unless a
5338 target is specified, in which case we copy the result into the target
5339 and return the assignment statement. */
5340 if (function_call)
5342 /* If this is a function with copy-in/copy-out parameters, extract the
5343 return value from it and update the return type. */
5344 if (TYPE_CI_CO_LIST (gnu_subprog_type))
5346 tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
5347 gnu_call
5348 = build_component_ref (gnu_call, TREE_PURPOSE (gnu_elmt), false);
5349 gnu_result_type = TREE_TYPE (gnu_call);
5352 /* If the function returns by direct reference, we have to dereference
5353 the pointer. */
5354 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
5355 gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
5357 if (gnu_target)
5359 Node_Id gnat_parent = Parent (gnat_node);
5360 enum tree_code op_code;
5362 gigi_checking_assert (!Do_Range_Check (gnat_node));
5364 /* ??? If the return type has variable size, then force the return
5365 slot optimization as we would not be able to create a temporary.
5366 That's what has been done historically. */
5367 if (return_type_with_variable_size_p (gnu_result_type))
5368 op_code = INIT_EXPR;
5370 /* If this is a call to a pure function returning an array of scalar
5371 type, try to apply the return slot optimization. */
5372 else if ((TYPE_READONLY (gnu_subprog_type)
5373 || TYPE_RESTRICT (gnu_subprog_type))
5374 && is_array_of_scalar_type (gnu_result_type)
5375 && TYPE_MODE (gnu_result_type) == BLKmode
5376 && aggregate_value_p (gnu_result_type, gnu_subprog_type)
5377 && return_slot_opt_for_pure_call_p (gnu_target, gnu_call))
5378 op_code = INIT_EXPR;
5380 /* If this is the initialization of a return object in a function
5381 returning by invisible reference, we can always use the return
5382 slot optimization. */
5383 else if (TREE_CODE (gnu_target) == INDIRECT_REF
5384 && TREE_CODE (TREE_OPERAND (gnu_target, 0)) == RESULT_DECL
5385 && current_function_decl
5386 && TREE_ADDRESSABLE (TREE_TYPE (current_function_decl)))
5387 op_code = INIT_EXPR;
5389 else
5390 op_code = MODIFY_EXPR;
5392 /* Use the required method to move the result to the target. */
5393 if (atomic_access == OUTER_ATOMIC)
5394 gnu_call
5395 = build_load_modify_store (gnu_target, gnu_call, gnat_node);
5396 else if (atomic_access == SIMPLE_ATOMIC)
5397 gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
5398 else if (Present (gnat_smo)
5399 && Present (Storage_Model_Copy_To (gnat_smo)))
5400 gnu_call
5401 = build_storage_model_store (gnat_smo, gnu_target, gnu_call);
5402 else
5403 gnu_call
5404 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
5406 if (EXPR_P (gnu_call))
5407 set_expr_location_from_node (gnu_call, gnat_parent);
5408 append_to_statement_list (gnu_call, &gnu_stmt_list);
5410 else
5411 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
5414 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
5415 parameters, the result is just the call statement. */
5416 else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
5417 append_to_statement_list (gnu_call, &gnu_stmt_list);
5419 /* Finally, add the copy back statements, if any. */
5420 append_to_statement_list (gnu_after_list, &gnu_stmt_list);
5422 if (went_into_elab_proc)
5423 current_function_decl = NULL_TREE;
5425 /* If we have pushed a binding level, pop it and finish up the enclosing
5426 statement group. */
5427 if (pushed_binding_level)
5429 add_stmt (gnu_stmt_list);
5430 gnat_poplevel ();
5431 gnu_result = end_stmt_group ();
5434 /* Otherwise, retrieve the statement list, if any. */
5435 else if (gnu_stmt_list)
5436 gnu_result = gnu_stmt_list;
5438 /* Otherwise, just return the call expression. */
5439 else
5440 return gnu_call;
5442 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
5443 But first simplify if we have only one statement in the list. */
5444 if (returning_value)
5446 tree first = expr_first (gnu_result), last = expr_last (gnu_result);
5447 if (first == last)
5448 gnu_result = first;
5449 gnu_result
5450 = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
5453 return gnu_result;
5456 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an
5457 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
5459 static tree
5460 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
5462 /* If just annotating, ignore all EH and cleanups. */
5463 const bool eh
5464 = !type_annotate_only && Present (Exception_Handlers (gnat_node));
5465 const bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
5466 tree gnu_result;
5467 Node_Id gnat_temp;
5469 /* The exception handling mechanism can handle both ZCX and SJLJ schemes, and
5470 is exposed through the TRY_CATCH_EXPR construct that we build manually.
5472 ??? The region level calls down there have been specifically put in place
5473 for a ZCX context and currently the order in which things are emitted
5474 (region/handlers) is different from the SJLJ case. Instead of putting
5475 other calls with different conditions at other places for the SJLJ case,
5476 it seems cleaner to reorder things for the SJLJ case and generalize the
5477 condition to make it not ZCX specific. */
5479 /* First build the tree for the statements inside the sequence. */
5480 start_stmt_group ();
5482 for (gnat_temp = First (Statements (gnat_node));
5483 Present (gnat_temp);
5484 gnat_temp = Next (gnat_temp))
5485 add_stmt (gnat_to_gnu (gnat_temp));
5487 gnu_result = end_stmt_group ();
5489 /* Then process the exception handlers, if any. */
5490 if (eh)
5492 tree gnu_handlers;
5493 location_t locus;
5495 /* First make a group containing the handlers. */
5496 start_stmt_group ();
5497 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5498 Present (gnat_temp);
5499 gnat_temp = Next_Non_Pragma (gnat_temp))
5500 add_stmt (gnat_to_gnu (gnat_temp));
5501 gnu_handlers = end_stmt_group ();
5503 /* Now make the TRY_CATCH_EXPR for the group. */
5504 gnu_result
5505 = build2 (TRY_CATCH_EXPR, void_type_node, gnu_result, gnu_handlers);
5507 /* Set a location. We need to find a unique location for the dispatching
5508 code, otherwise we can get coverage or debugging issues. Try with
5509 the location of the end label. */
5510 if (Present (End_Label (gnat_node))
5511 && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus))
5512 SET_EXPR_LOCATION (gnu_result, locus);
5513 else
5514 /* Clear column information so that the exception handler of an
5515 implicit transient block does not incorrectly inherit the slocs
5516 of a decision, which would otherwise confuse control flow based
5517 coverage analysis tools. */
5518 set_expr_location_from_node (gnu_result, gnat_node, true);
5521 /* Process the At_End_Proc, if any. */
5522 if (at_end)
5524 start_stmt_group ();
5525 add_stmt (gnu_result);
5526 At_End_Proc_to_gnu (gnat_node);
5527 gnu_result = end_stmt_group ();
5530 return gnu_result;
5533 /* Return true if no statement in GNAT_LIST can alter the control flow. */
5535 static bool
5536 stmt_list_cannot_alter_control_flow_p (List_Id gnat_list)
5538 if (No (gnat_list))
5539 return true;
5541 /* This is very conservative, we reject everything except for simple
5542 assignments between identifiers or literals. */
5543 for (Node_Id gnat_node = First (gnat_list);
5544 Present (gnat_node);
5545 gnat_node = Next (gnat_node))
5547 if (Nkind (gnat_node) != N_Assignment_Statement)
5548 return false;
5550 if (Nkind (Name (gnat_node)) != N_Identifier)
5551 return false;
5553 Node_Kind nkind = Nkind (Expression (gnat_node));
5554 if (nkind != N_Identifier
5555 && nkind != N_Integer_Literal
5556 && nkind != N_Real_Literal)
5557 return false;
5560 return true;
5563 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Exception_Handler,
5564 to a GCC tree, which is returned. */
5566 static tree
5567 Exception_Handler_to_gnu (Node_Id gnat_node)
5569 tree gnu_etypes_list = NULL_TREE;
5571 /* We build a TREE_LIST of nodes representing what exception types this
5572 handler can catch, with special cases for others and all others cases.
5574 Each exception type is actually identified by a pointer to the exception
5575 id, or to a dummy object for "others" and "all others". */
5576 for (Node_Id gnat_temp = First (Exception_Choices (gnat_node));
5577 gnat_temp;
5578 gnat_temp = Next (gnat_temp))
5580 tree gnu_expr, gnu_etype;
5582 if (Nkind (gnat_temp) == N_Others_Choice)
5584 gnu_expr = All_Others (gnat_temp) ? all_others_decl : others_decl;
5585 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5587 else if (Nkind (gnat_temp) == N_Identifier
5588 || Nkind (gnat_temp) == N_Expanded_Name)
5590 Entity_Id gnat_ex_id = Entity (gnat_temp);
5592 /* Exception may be a renaming. Recover original exception which is
5593 the one elaborated and registered. */
5594 if (Present (Renamed_Object (gnat_ex_id)))
5595 gnat_ex_id = Renamed_Object (gnat_ex_id);
5597 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
5598 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5600 else
5601 gcc_unreachable ();
5603 /* The GCC interface expects NULL to be passed for catch all handlers, so
5604 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5605 is integer_zero_node. It would not work, however, because GCC's
5606 notion of "catch all" is stronger than our notion of "others". Until
5607 we correctly use the cleanup interface as well, doing that would
5608 prevent the "all others" handlers from being seen, because nothing
5609 can be caught beyond a catch all from GCC's point of view. */
5610 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
5613 start_stmt_group ();
5615 /* Expand a call to the begin_handler hook at the beginning of the
5616 handler, and arrange for a call to the end_handler hook to occur
5617 on every possible exit path. GDB sets a breakpoint in the
5618 begin_handler for catchpoints.
5620 A v1 begin handler saves the cleanup from the exception object,
5621 and marks the exception as in use, so that it will not be
5622 released by other handlers. A v1 end handler restores the
5623 cleanup and releases the exception object, unless it is still
5624 claimed, or the exception is being propagated (reraised).
5626 __builtin_eh_pointer references the exception occurrence being
5627 handled or propagated. Within the handler region, it is the
5628 former, but within the else branch of the EH_ELSE_EXPR, i.e. the
5629 exceptional cleanup path, it is the latter, so we must save the
5630 occurrence being handled early on, so that, should an exception
5631 be (re)raised, we can release the current exception, or figure
5632 out we're not to release it because we're propagating a reraise
5633 thereof.
5635 We use local variables to retrieve the incoming value at handler
5636 entry time (EXPTR), the saved cleanup (EXCLN) and the token
5637 (EXVTK), and reuse them to feed the end_handler hook's argument
5638 at exit. */
5640 /* CODE: void *EXPTR = __builtin_eh_pointer (0); */
5641 tree gnu_current_exc_ptr
5642 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
5643 1, integer_zero_node);
5644 tree exc_ptr
5645 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
5646 ptr_type_node, gnu_current_exc_ptr,
5647 true, false, false, false, false, true, true,
5648 NULL, gnat_node);
5650 tree prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
5651 gnu_incoming_exc_ptr = exc_ptr;
5653 /* begin_handler_decl must not throw, so we can use it as an
5654 initializer for a variable used in cleanups.
5656 CODE: void *EXCLN = __gnat_begin_handler_v1 (EXPTR); */
5657 tree exc_cleanup
5658 = create_var_decl (get_identifier ("EXCLN"), NULL_TREE,
5659 ptr_type_node,
5660 build_call_n_expr (begin_handler_decl, 1,
5661 exc_ptr),
5662 true, false, false, false, false,
5663 true, true, NULL, gnat_node);
5665 /* Declare and initialize the choice parameter, if present. */
5666 if (Present (Choice_Parameter (gnat_node)))
5668 tree gnu_param
5669 = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, true);
5671 /* CODE: __gnat_set_exception_parameter (&choice_param, EXPTR); */
5672 add_stmt (build_call_n_expr
5673 (set_exception_parameter_decl, 2,
5674 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param),
5675 gnu_incoming_exc_ptr));
5678 /* CODE: <handler proper> */
5679 add_stmt_list (Statements (gnat_node));
5681 tree call = build_call_n_expr (end_handler_decl, 3,
5682 exc_ptr,
5683 exc_cleanup,
5684 null_pointer_node);
5685 /* If the handler can only end by falling off the end, don't bother
5686 with cleanups. */
5687 if (stmt_list_cannot_alter_control_flow_p (Statements (gnat_node)))
5688 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, NULL); */
5689 add_stmt_with_node (call, gnat_node);
5690 /* Otherwise, all of the above is after
5691 CODE: try {
5693 The call above will appear after
5694 CODE: } finally {
5696 And the code below will appear after
5697 CODE: } else {
5699 The else block to a finally block is taken instead of the finally
5700 block when an exception propagates out of the try block. */
5701 else
5703 start_stmt_group ();
5705 /* CODE: void *EXPRP = __builtin_eh_handler (0); */
5706 tree prop_ptr
5707 = create_var_decl (get_identifier ("EXPRP"), NULL_TREE,
5708 ptr_type_node,
5709 build_call_expr (builtin_decl_explicit
5710 (BUILT_IN_EH_POINTER),
5711 1, integer_zero_node),
5712 true, false, false, false, false,
5713 true, true, NULL, gnat_node);
5715 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, EXPRP); */
5716 tree ecall = build_call_n_expr (end_handler_decl, 3,
5717 exc_ptr,
5718 exc_cleanup,
5719 prop_ptr);
5721 add_stmt_with_node (ecall, gnat_node);
5723 /* CODE: } */
5724 tree eblk = end_stmt_group ();
5725 tree ehls = build2 (EH_ELSE_EXPR, void_type_node, call, eblk);
5726 add_cleanup (ehls, gnat_node);
5729 gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
5731 return
5732 build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ());
5735 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Compilation_Unit. */
5737 static void
5738 Compilation_Unit_to_gnu (Node_Id gnat_node)
5740 const Node_Id gnat_unit = Unit (gnat_node);
5741 const bool body_p = (Nkind (gnat_unit) == N_Package_Body
5742 || Nkind (gnat_unit) == N_Subprogram_Body);
5743 const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
5744 Entity_Id gnat_entity;
5745 Node_Id gnat_pragma, gnat_iter;
5746 /* Make the decl for the elaboration procedure. Emit debug info for it, so
5747 that users can break into their elaboration code in debuggers. Kludge:
5748 don't consider it as a definition so that we have a line map for its
5749 body, but no subprogram description in debug info. In addition, don't
5750 qualify it as artificial, even though it is not a user subprogram per se,
5751 in particular for specs. Unlike, say, clones created internally by the
5752 compiler, this subprogram materializes specific user code and flagging it
5753 artificial would take elab code away from gcov's analysis. */
5754 tree gnu_elab_proc_decl
5755 = create_subprog_decl
5756 (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
5757 NULL_TREE, void_ftype, NULL_TREE,
5758 is_default, true, false, false, true, false, NULL, gnat_unit);
5759 struct elab_info *info;
5761 vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
5762 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
5764 /* Initialize the information structure for the function. */
5765 allocate_struct_function (gnu_elab_proc_decl, false);
5766 set_cfun (NULL);
5768 current_function_decl = NULL_TREE;
5770 start_stmt_group ();
5771 gnat_pushlevel ();
5773 /* For a body, first process the spec if there is one. */
5774 if (Nkind (gnat_unit) == N_Package_Body
5775 || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
5776 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
5778 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
5780 elaborate_all_entities (gnat_node);
5782 if (Nkind (gnat_unit) == N_Subprogram_Declaration
5783 || Nkind (gnat_unit) == N_Generic_Package_Declaration
5784 || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
5785 return;
5788 /* Then process any pragmas and declarations preceding the unit. */
5789 for (gnat_pragma = First (Context_Items (gnat_node));
5790 Present (gnat_pragma);
5791 gnat_pragma = Next (gnat_pragma))
5792 if (Nkind (gnat_pragma) == N_Pragma)
5793 add_stmt (gnat_to_gnu (gnat_pragma));
5794 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty,
5795 true, true);
5797 /* Process the unit itself. */
5798 add_stmt (gnat_to_gnu (gnat_unit));
5800 /* Generate code for all the inlined subprograms. */
5801 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5802 Present (gnat_entity);
5803 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5805 Node_Id gnat_body;
5807 /* Without optimization, process only the required subprograms. */
5808 if (!optimize && !Has_Pragma_Inline_Always (gnat_entity))
5809 continue;
5811 /* The set of inlined subprograms is computed from data recorded early
5812 during expansion and it can be a strict superset of the final set
5813 computed after semantic analysis, for example if a call to such a
5814 subprogram occurs in a pragma Assert and assertions are disabled.
5815 In that case, semantic analysis resets Is_Public to false but the
5816 entry for the subprogram in the inlining tables is stalled. */
5817 if (!Is_Public (gnat_entity))
5818 continue;
5820 gnat_body = Parent (Declaration_Node (gnat_entity));
5821 if (Nkind (gnat_body) != N_Subprogram_Body)
5823 /* ??? This happens when only the spec of a package is provided. */
5824 if (No (Corresponding_Body (gnat_body)))
5825 continue;
5827 gnat_body
5828 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5831 /* Define the entity first so we set DECL_EXTERNAL. */
5832 gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
5833 add_stmt (gnat_to_gnu (gnat_body));
5836 /* Process any pragmas and actions following the unit. */
5837 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
5838 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
5839 finalize_from_limited_with ();
5841 /* Then process the expressions of pragma Compile_Time_{Error|Warning} to
5842 annotate types referenced therein if they have not been annotated. */
5843 for (int i = 0; gnat_compile_time_expr_list.iterate (i, &gnat_iter); i++)
5844 (void) gnat_to_gnu_external (gnat_iter);
5845 gnat_compile_time_expr_list.release ();
5847 /* Save away what we've made so far and finish it up. */
5848 set_current_block_context (gnu_elab_proc_decl);
5849 gnat_poplevel ();
5850 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
5851 set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
5852 gnu_elab_proc_stack->pop ();
5854 /* Record this potential elaboration procedure for later processing. */
5855 info = ggc_alloc<elab_info> ();
5856 info->next = elab_info_list;
5857 info->elab_proc = gnu_elab_proc_decl;
5858 info->gnat_node = gnat_node;
5859 elab_info_list = info;
5861 /* Force the processing for all nodes that remain in the queue. */
5862 process_deferred_decl_context (true);
5865 /* Mark COND, a boolean expression, as predicating a call to a noreturn
5866 function, i.e. predict that it is very likely false, and return it.
5868 The compiler will automatically predict the last edge leading to a call
5869 to a noreturn function as very unlikely taken. This function makes it
5870 possible to extend the prediction to predecessors in case the condition
5871 is made up of several short-circuit operators. */
5873 static tree
5874 build_noreturn_cond (tree cond)
5876 tree pred_cst = build_int_cst (integer_type_node, PRED_NORETURN);
5877 return
5878 build_call_expr_internal_loc (UNKNOWN_LOCATION, IFN_BUILTIN_EXPECT,
5879 boolean_type_node, 3, cond,
5880 boolean_false_node, pred_cst);
5883 /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
5884 range of values, into GNU_LOW and GNU_HIGH bounds. */
5886 static void
5887 Range_to_gnu (Node_Id gnat_range, tree *gnu_low, tree *gnu_high)
5889 /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
5890 switch (Nkind (gnat_range))
5892 case N_Range:
5893 *gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
5894 *gnu_high = gnat_to_gnu (High_Bound (gnat_range));
5895 break;
5897 case N_Expanded_Name:
5898 case N_Identifier:
5900 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
5901 tree gnu_range_base_type = get_base_type (gnu_range_type);
5903 *gnu_low
5904 = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
5905 *gnu_high
5906 = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
5908 break;
5910 default:
5911 gcc_unreachable ();
5915 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
5916 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
5917 where we should place the result type. */
5919 static tree
5920 Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
5922 const Node_Kind kind = Nkind (gnat_node);
5923 const Node_Id gnat_cond = Condition (gnat_node);
5924 const int reason = UI_To_Int (Reason (gnat_node));
5925 const bool with_extra_info
5926 = Exception_Extra_Info
5927 && !No_Exception_Handlers_Set ()
5928 && No (get_exception_label (kind));
5929 tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
5930 Node_Id gnat_rcond;
5932 /* The following processing is not required for correctness. Its purpose is
5933 to give more precise error messages and to record some information. */
5934 switch (reason)
5936 case CE_Access_Check_Failed:
5937 if (with_extra_info)
5938 gnu_result = build_call_raise_column (reason, gnat_node, kind);
5939 break;
5941 case CE_Index_Check_Failed:
5942 case CE_Range_Check_Failed:
5943 case CE_Invalid_Data:
5944 if (No (gnat_cond) || Nkind (gnat_cond) != N_Op_Not)
5945 break;
5946 gnat_rcond = Right_Opnd (gnat_cond);
5947 if (Nkind (gnat_rcond) == N_In
5948 || Nkind (gnat_rcond) == N_Op_Ge
5949 || Nkind (gnat_rcond) == N_Op_Le)
5951 const Node_Id gnat_index = Left_Opnd (gnat_rcond);
5952 const Node_Id gnat_type = Etype (gnat_index);
5953 tree gnu_index = gnat_to_gnu (gnat_index);
5954 tree gnu_type = get_unpadded_type (gnat_type);
5955 tree gnu_low_bound, gnu_high_bound, disp;
5956 struct loop_info_d *loop;
5957 bool neg_p;
5959 switch (Nkind (gnat_rcond))
5961 case N_In:
5962 Range_to_gnu (Right_Opnd (gnat_rcond),
5963 &gnu_low_bound, &gnu_high_bound);
5964 break;
5966 case N_Op_Ge:
5967 gnu_low_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
5968 gnu_high_bound = TYPE_MAX_VALUE (gnu_type);
5969 break;
5971 case N_Op_Le:
5972 gnu_low_bound = TYPE_MIN_VALUE (gnu_type);
5973 gnu_high_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
5974 break;
5976 default:
5977 gcc_unreachable ();
5980 gnu_type = maybe_character_type (gnu_type);
5981 if (TREE_TYPE (gnu_index) != gnu_type)
5983 gnu_low_bound = convert (gnu_type, gnu_low_bound);
5984 gnu_high_bound = convert (gnu_type, gnu_high_bound);
5985 gnu_index = convert (gnu_type, gnu_index);
5988 if (with_extra_info
5989 && Known_Esize (gnat_type)
5990 && UI_To_Int (Esize (gnat_type)) <= 32)
5991 gnu_result
5992 = build_call_raise_range (reason, gnat_node, kind, gnu_index,
5993 gnu_low_bound, gnu_high_bound);
5995 /* If optimization is enabled and we are inside a loop, we try to
5996 compute invariant conditions for checks applied to the iteration
5997 variable, i.e. conditions that are independent of the variable
5998 and necessary in order for the checks to fail in the course of
5999 some iteration. If we succeed, we consider an alternative:
6001 1. If loop unswitching is enabled, we prepend these conditions
6002 to the original conditions of the checks. This will make it
6003 possible for the loop unswitching pass to replace the loop
6004 with two loops, one of which has the checks eliminated and
6005 the other has the original checks reinstated, and a prologue
6006 implementing a run-time selection. The former loop will be
6007 for example suitable for vectorization.
6009 2. Otherwise, we instead append the conditions to the original
6010 conditions of the checks. At worse, if the conditions cannot
6011 be evaluated at compile time, they will be evaluated as true
6012 at run time only when the checks have already failed, thus
6013 contributing negatively only to the size of the executable.
6014 But the hope is that these invariant conditions be evaluated
6015 at compile time to false, thus taking away the entire checks
6016 with them. */
6017 if (optimize
6018 && inside_loop_p ()
6019 && (!gnu_low_bound
6020 || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)))
6021 && (!gnu_high_bound
6022 || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)))
6023 && (loop = find_loop_for (gnu_index, &disp, &neg_p)))
6025 struct range_check_info_d *rci = ggc_alloc<range_check_info_d> ();
6026 rci->low_bound = gnu_low_bound;
6027 rci->high_bound = gnu_high_bound;
6028 rci->disp = disp;
6029 rci->neg_p = neg_p;
6030 rci->type = gnu_type;
6031 rci->inserted_cond
6032 = build1 (SAVE_EXPR, boolean_type_node, boolean_true_node);
6033 vec_safe_push (loop->checks, rci);
6034 gnu_cond = build_noreturn_cond (gnat_to_gnu (gnat_cond));
6035 if (optimize >= 3)
6036 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
6037 boolean_type_node,
6038 rci->inserted_cond,
6039 gnu_cond);
6040 else
6041 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
6042 boolean_type_node,
6043 gnu_cond,
6044 rci->inserted_cond);
6047 break;
6049 default:
6050 break;
6053 /* The following processing does the real work, but we must nevertheless make
6054 sure not to override the result of the previous processing. */
6055 if (!gnu_result)
6056 gnu_result = build_call_raise (reason, gnat_node, kind);
6057 set_expr_location_from_node (gnu_result, gnat_node);
6059 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
6061 /* If the type is VOID, this is a statement, so we need to generate the code
6062 for the call. Handle a condition, if there is one. */
6063 if (VOID_TYPE_P (*gnu_result_type_p))
6065 if (Present (gnat_cond))
6067 if (!gnu_cond)
6068 gnu_cond = gnat_to_gnu (gnat_cond);
6069 if (integer_zerop (gnu_cond))
6070 return alloc_stmt_list ();
6071 gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
6072 alloc_stmt_list ());
6075 else
6077 /* The condition field must not be present when the node is used as an
6078 expression form. */
6079 gigi_checking_assert (No (gnat_cond));
6080 gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
6083 return gnu_result;
6086 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
6087 parameter of a call. */
6089 static bool
6090 lhs_or_actual_p (Node_Id gnat_node)
6092 const Node_Id gnat_parent = Parent (gnat_node);
6093 const Node_Kind kind = Nkind (gnat_parent);
6095 if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
6096 return true;
6098 if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
6099 && Name (gnat_parent) != gnat_node)
6100 return true;
6102 if (kind == N_Parameter_Association)
6103 return true;
6105 return false;
6108 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
6109 of an assignment or an actual parameter of a call. */
6111 static bool
6112 present_in_lhs_or_actual_p (Node_Id gnat_node)
6114 if (lhs_or_actual_p (gnat_node))
6115 return true;
6117 const Node_Kind kind = Nkind (Parent (gnat_node));
6119 if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
6120 && lhs_or_actual_p (Parent (gnat_node)))
6121 return true;
6123 return false;
6126 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
6127 as gigi is concerned. This is used to avoid conversions on the LHS. */
6129 static bool
6130 unchecked_conversion_nop (Node_Id gnat_node)
6132 Entity_Id from_type, to_type;
6134 /* The conversion must be on the LHS of an assignment or an actual parameter
6135 of a call. Otherwise, even if the conversion was essentially a no-op, it
6136 could de facto ensure type consistency and this should be preserved. */
6137 if (!lhs_or_actual_p (gnat_node))
6138 return false;
6140 from_type = Etype (Expression (gnat_node));
6142 /* We're interested in artificial conversions generated by the front-end
6143 to make private types explicit, e.g. in Expand_Assign_Array. */
6144 if (!Is_Private_Type (from_type))
6145 return false;
6147 from_type = Underlying_Type (from_type);
6148 to_type = Etype (gnat_node);
6150 /* The direct conversion to the underlying type is a no-op. */
6151 if (to_type == from_type)
6152 return true;
6154 /* For an array subtype, the conversion to the PAIT is a no-op. */
6155 if (Ekind (from_type) == E_Array_Subtype
6156 && to_type == Packed_Array_Impl_Type (from_type))
6157 return true;
6159 /* For a record subtype, the conversion to the type is a no-op. */
6160 if (Ekind (from_type) == E_Record_Subtype
6161 && to_type == Etype (from_type))
6162 return true;
6164 return false;
6167 /* Return true if GNAT_NODE represents a statement. */
6169 static bool
6170 statement_node_p (Node_Id gnat_node)
6172 const Node_Kind kind = Nkind (gnat_node);
6174 if (kind == N_Label)
6175 return true;
6177 if (IN (kind, N_Statement_Other_Than_Procedure_Call))
6178 return true;
6180 if (kind == N_Procedure_Call_Statement)
6181 return true;
6183 if (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void)
6184 return true;
6186 return false;
6189 /* This function is the driver of the GNAT to GCC tree transformation process.
6190 It is the entry point of the tree transformer. GNAT_NODE is the root of
6191 some GNAT tree. Return the root of the corresponding GCC tree. If this
6192 is an expression, return the GCC equivalent of the expression. If this
6193 is a statement, return the statement or add it to the current statement
6194 group, in which case anything returned is to be interpreted as occurring
6195 after anything added. */
6197 tree
6198 gnat_to_gnu (Node_Id gnat_node)
6200 const Node_Kind kind = Nkind (gnat_node);
6201 tree gnu_result = error_mark_node; /* Default to no value. */
6202 tree gnu_result_type = void_type_node;
6203 tree gnu_expr, gnu_lhs, gnu_rhs;
6204 Node_Id gnat_temp;
6205 atomic_acces_t aa_type;
6206 bool went_into_elab_proc;
6207 bool aa_sync;
6208 Entity_Id gnat_smo;
6210 /* Save node number for error message and set location information. */
6211 if (Sloc (gnat_node) > No_Location)
6212 Current_Error_Node = gnat_node;
6213 Sloc_to_locus (Sloc (gnat_node), &input_location);
6215 /* If we are only annotating types and this node is a statement, return
6216 an empty statement list. */
6217 if (type_annotate_only && statement_node_p (gnat_node))
6218 return alloc_stmt_list ();
6220 /* If we are only annotating types and this node is a subexpression, return
6221 a NULL_EXPR, but filter out nodes appearing in the expressions attached
6222 to packed array implementation types. */
6223 if (type_annotate_only
6224 && IN (kind, N_Subexpr)
6225 && !(((IN (kind, N_Op) && kind != N_Op_Expon)
6226 || kind == N_Type_Conversion)
6227 && Is_Integer_Type (Etype (gnat_node)))
6228 && !(kind == N_Attribute_Reference
6229 && (Get_Attribute_Id (Attribute_Name (gnat_node)) == Attr_Length
6230 || Get_Attribute_Id (Attribute_Name (gnat_node)) == Attr_Size)
6231 && Is_Constrained (Etype (Prefix (gnat_node)))
6232 && !Is_Constr_Subt_For_U_Nominal (Etype (Prefix (gnat_node))))
6233 && kind != N_Expanded_Name
6234 && kind != N_Identifier
6235 && !Compile_Time_Known_Value (gnat_node))
6236 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
6237 build_call_raise (CE_Range_Check_Failed, gnat_node,
6238 N_Raise_Constraint_Error));
6240 /* If this is a statement and we are at top level, it must be part of the
6241 elaboration procedure, so mark us as being in that procedure. */
6242 if ((statement_node_p (gnat_node)
6243 || kind == N_Handled_Sequence_Of_Statements
6244 || kind == N_Implicit_Label_Declaration)
6245 && !current_function_decl)
6247 current_function_decl = get_elaboration_procedure ();
6248 went_into_elab_proc = true;
6250 else
6251 went_into_elab_proc = false;
6253 switch (kind)
6255 /********************************/
6256 /* Chapter 2: Lexical Elements */
6257 /********************************/
6259 case N_Identifier:
6260 case N_Expanded_Name:
6261 case N_Operator_Symbol:
6262 case N_Defining_Identifier:
6263 case N_Defining_Operator_Symbol:
6264 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
6266 /* If atomic access is required on the RHS, build the atomic load. */
6267 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6268 && !present_in_lhs_or_actual_p (gnat_node))
6269 gnu_result = build_atomic_load (gnu_result, aa_sync);
6270 break;
6272 case N_Integer_Literal:
6274 tree gnu_type;
6276 /* Get the type of the result, looking inside any padding and
6277 justified modular types. Then get the value in that type. */
6278 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
6280 if (TREE_CODE (gnu_type) == RECORD_TYPE
6281 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
6282 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
6284 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
6286 /* If the result overflows (meaning it doesn't fit in its base type),
6287 abort, unless this is for a named number because that's not fatal.
6288 We would like to check that the value is within the range of the
6289 subtype, but that causes problems with subtypes whose usage will
6290 raise Constraint_Error and also with biased representation. */
6291 if (TREE_OVERFLOW (gnu_result))
6293 if (Nkind (Parent (gnat_node)) == N_Number_Declaration)
6294 gnu_result = error_mark_node;
6295 else
6296 gcc_unreachable ();
6299 break;
6301 case N_Character_Literal:
6302 /* If a Entity is present, it means that this was one of the
6303 literals in a user-defined character type. In that case,
6304 just return the value in the CONST_DECL. Otherwise, use the
6305 character code. In that case, the base type should be an
6306 INTEGER_TYPE, but we won't bother checking for that. */
6307 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6308 if (Present (Entity (gnat_node)))
6309 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
6310 else
6311 gnu_result
6312 = build_int_cst (gnu_result_type,
6313 UI_To_CC (Char_Literal_Value (gnat_node)));
6314 break;
6316 case N_Real_Literal:
6317 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6319 /* If this is of a fixed-point type, the value we want is the value of
6320 the corresponding integer. */
6321 if (Is_Fixed_Point_Type (Underlying_Type (Etype (gnat_node))))
6323 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
6324 gnu_result_type);
6325 gcc_assert (!TREE_OVERFLOW (gnu_result));
6328 else
6330 Ureal ur_realval = Realval (gnat_node);
6332 /* First convert the value to a machine number if it isn't already.
6333 That will force the base to 2 for non-zero values and simplify
6334 the rest of the logic. */
6335 if (!Is_Machine_Number (gnat_node))
6336 ur_realval
6337 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
6338 ur_realval, Round_Even, gnat_node);
6340 if (UR_Is_Zero (ur_realval))
6341 gnu_result = build_real (gnu_result_type, dconst0);
6342 else
6344 REAL_VALUE_TYPE tmp;
6346 gnu_result = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
6348 /* The base must be 2 as Machine guarantees this, so we scale
6349 the value, which we know can fit in the mantissa of the type
6350 (hence the use of that type above). */
6351 gcc_assert (Rbase (ur_realval) == 2);
6352 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
6353 - UI_To_Int (Denominator (ur_realval)));
6354 gnu_result = build_real (gnu_result_type, tmp);
6357 /* Now see if we need to negate the result. Do it this way to
6358 properly handle -0. */
6359 if (UR_Is_Negative (Realval (gnat_node)))
6360 gnu_result
6361 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
6362 gnu_result);
6365 break;
6367 case N_String_Literal:
6368 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6369 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
6371 String_Id gnat_string = Strval (gnat_node);
6372 int length = String_Length (gnat_string);
6373 int i;
6374 char *string;
6375 if (length >= ALLOCA_THRESHOLD)
6376 string = XNEWVEC (char, length);
6377 else
6378 string = (char *) alloca (length);
6380 /* Build the string with the characters in the literal. Note
6381 that Ada strings are 1-origin. */
6382 for (i = 0; i < length; i++)
6383 string[i] = Get_String_Char (gnat_string, i + 1);
6385 gnu_result = build_string (length, string);
6387 /* Strings in GCC don't normally have types, but we want
6388 this to not be converted to the array type. */
6389 TREE_TYPE (gnu_result) = gnu_result_type;
6391 if (length >= ALLOCA_THRESHOLD)
6392 free (string);
6394 else
6396 /* Build a list consisting of each character, then make
6397 the aggregate. */
6398 String_Id gnat_string = Strval (gnat_node);
6399 int length = String_Length (gnat_string);
6400 int i;
6401 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6402 tree gnu_one_node = convert (TREE_TYPE (gnu_idx), integer_one_node);
6403 vec<constructor_elt, va_gc> *gnu_vec;
6404 vec_alloc (gnu_vec, length);
6406 for (i = 0; i < length; i++)
6408 tree t = build_int_cst (TREE_TYPE (gnu_result_type),
6409 Get_String_Char (gnat_string, i + 1));
6411 CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
6412 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, gnu_one_node);
6415 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
6417 break;
6419 case N_Pragma:
6420 gnu_result = Pragma_to_gnu (gnat_node);
6421 break;
6423 /**************************************/
6424 /* Chapter 3: Declarations and Types */
6425 /**************************************/
6427 case N_Subtype_Declaration:
6428 case N_Full_Type_Declaration:
6429 case N_Incomplete_Type_Declaration:
6430 case N_Private_Type_Declaration:
6431 case N_Private_Extension_Declaration:
6432 case N_Task_Type_Declaration:
6433 process_type (Defining_Entity (gnat_node));
6434 gnu_result = alloc_stmt_list ();
6435 break;
6437 case N_Object_Declaration:
6438 case N_Number_Declaration:
6439 case N_Exception_Declaration:
6440 gnat_temp = Defining_Entity (gnat_node);
6441 gnu_result = alloc_stmt_list ();
6443 /* If we are just annotating types and this object has an unconstrained
6444 or task type, don't elaborate it. */
6445 if (type_annotate_only
6446 && (((Is_Array_Type (Etype (gnat_temp))
6447 || Is_Record_Type (Etype (gnat_temp)))
6448 && !Is_Constrained (Etype (gnat_temp)))
6449 || Is_Concurrent_Type (Etype (gnat_temp))))
6450 break;
6452 /* If this is a constant related to a return initialized by a reference
6453 to a function call in a function returning by invisible reference:
6455 type Ann is access all Result_Type;
6456 Rnn : constant Ann := Func'reference;
6457 [...]
6458 return Rnn.all;
6460 then elide the temporary by forwarding the return object to Func:
6462 result_type *Rnn = (result_type *) <retval>;
6463 *<retval> = Func (); [return slot optimization]
6464 [...]
6465 return Rnn;
6467 That's necessary if the result type needs finalization because the
6468 temporary would never be adjusted as Expand_Simple_Function_Return
6469 also elides the temporary in this case. */
6470 if (Ekind (gnat_temp) == E_Constant
6471 && Is_Related_To_Func_Return (gnat_temp)
6472 && Nkind (Expression (gnat_node)) == N_Reference
6473 && Nkind (Prefix (Expression (gnat_node))) == N_Function_Call
6474 && current_function_decl
6475 && TREE_ADDRESSABLE (TREE_TYPE (current_function_decl)))
6477 gnat_to_gnu_entity (gnat_temp,
6478 DECL_RESULT (current_function_decl),
6479 true);
6480 gnu_result
6481 = build_unary_op (INDIRECT_REF, NULL_TREE,
6482 DECL_RESULT (current_function_decl));
6483 gnu_result
6484 = Call_to_gnu (Prefix (Expression (gnat_node)),
6485 &gnu_result_type, gnu_result,
6486 NOT_ATOMIC, false, Empty);
6487 break;
6490 if (Present (Expression (gnat_node))
6491 && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
6492 && (!type_annotate_only
6493 || Compile_Time_Known_Value (Expression (gnat_node))))
6495 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node)));
6497 gnu_expr = gnat_to_gnu (Expression (gnat_node));
6499 /* First deal with erroneous expressions. */
6500 if (TREE_CODE (gnu_expr) == ERROR_MARK)
6502 /* If this is a named number for which we cannot manipulate
6503 the value, just skip the declaration altogether. */
6504 if (kind == N_Number_Declaration)
6505 break;
6506 else if (type_annotate_only)
6507 gnu_expr = NULL_TREE;
6510 /* Then a special case: we do not want the SLOC of the expression
6511 of the tag to pop up every time it is referenced somewhere. */
6512 else if (EXPR_P (gnu_expr) && Is_Tag (gnat_temp))
6513 SET_EXPR_LOCATION (gnu_expr, UNKNOWN_LOCATION);
6515 else
6516 gnu_expr = NULL_TREE;
6518 /* If this is a deferred constant with an address clause, we ignore the
6519 full view since the clause is on the partial view and we cannot have
6520 2 different GCC trees for the object. The only bits of the full view
6521 we will use is the initializer, but it will be directly fetched. */
6522 if (Ekind (gnat_temp) == E_Constant
6523 && Present (Address_Clause (gnat_temp))
6524 && Present (Full_View (gnat_temp)))
6525 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
6527 /* If this object has its elaboration delayed, we must force evaluation
6528 of GNU_EXPR now and save it for the freeze point. Note that we need
6529 not do anything special at the global level since the lifetime of the
6530 temporary is fully contained within the elaboration routine. */
6531 if (Present (Freeze_Node (gnat_temp)))
6533 if (gnu_expr)
6535 gnu_result = gnat_save_expr (gnu_expr);
6536 save_gnu_tree (gnat_node, gnu_result, true);
6539 else
6540 gnat_to_gnu_entity (gnat_temp, gnu_expr, true);
6541 break;
6543 case N_Object_Renaming_Declaration:
6544 gnat_temp = Defining_Entity (gnat_node);
6545 gnu_result = alloc_stmt_list ();
6547 /* Don't do anything if this renaming is handled by the front end and it
6548 does not need debug info. Note that we consider renamings don't need
6549 debug info when optimizing: our way to describe them has a
6550 memory/elaboration footprint.
6552 Don't do anything neither if we are just annotating types and this
6553 object has a composite or task type, don't elaborate it. */
6554 if ((!Is_Renaming_Of_Object (gnat_temp)
6555 || (Needs_Debug_Info (gnat_temp)
6556 && !optimize
6557 && can_materialize_object_renaming_p
6558 (Renamed_Object (gnat_temp))))
6559 && ! (type_annotate_only
6560 && (Is_Array_Type (Etype (gnat_temp))
6561 || Is_Record_Type (Etype (gnat_temp))
6562 || Is_Concurrent_Type (Etype (gnat_temp)))))
6563 gnat_to_gnu_entity (gnat_temp,
6564 gnat_to_gnu (Renamed_Object (gnat_temp)),
6565 true);
6566 break;
6568 case N_Exception_Renaming_Declaration:
6569 gnat_temp = Defining_Entity (gnat_node);
6570 gnu_result = alloc_stmt_list ();
6572 if (Present (Renamed_Entity (gnat_temp)))
6573 gnat_to_gnu_entity (gnat_temp,
6574 gnat_to_gnu (Renamed_Entity (gnat_temp)),
6575 true);
6576 break;
6578 case N_Subprogram_Renaming_Declaration:
6580 const Node_Id gnat_renaming = Defining_Entity (gnat_node);
6581 const Node_Id gnat_renamed = Renamed_Entity (gnat_renaming);
6583 gnu_result = alloc_stmt_list ();
6585 /* Materializing renamed subprograms will only benefit the debugging
6586 information as they aren't referenced in the generated code. So
6587 skip them when they aren't needed. Avoid doing this if:
6589 - there is a freeze node: in this case the renamed entity is not
6590 elaborated yet,
6591 - the renamed subprogram is intrinsic: it will not be available in
6592 the debugging information (note that both or only one of the
6593 renaming and the renamed subprograms can be intrinsic). */
6594 if (!type_annotate_only
6595 && Needs_Debug_Info (gnat_renaming)
6596 && No (Freeze_Node (gnat_renaming))
6597 && Present (gnat_renamed)
6598 && (Ekind (gnat_renamed) == E_Function
6599 || Ekind (gnat_renamed) == E_Procedure)
6600 && !Is_Intrinsic_Subprogram (gnat_renaming)
6601 && !Is_Intrinsic_Subprogram (gnat_renamed))
6602 gnat_to_gnu_entity (gnat_renaming, gnat_to_gnu (gnat_renamed), true);
6603 break;
6606 case N_Implicit_Label_Declaration:
6607 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
6608 gnu_result = alloc_stmt_list ();
6609 break;
6611 case N_Package_Renaming_Declaration:
6612 /* These are fully handled in the front end. */
6613 /* ??? For package renamings, find a way to use GENERIC namespaces so
6614 that we get proper debug information for them. */
6615 gnu_result = alloc_stmt_list ();
6616 break;
6618 /*************************************/
6619 /* Chapter 4: Names and Expressions */
6620 /*************************************/
6622 case N_Explicit_Dereference:
6623 /* Make sure the designated type is complete before dereferencing. */
6624 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6625 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6626 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
6628 /* If atomic access is required on the RHS, build the atomic load. */
6629 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6630 && !present_in_lhs_or_actual_p (gnat_node))
6631 gnu_result = build_atomic_load (gnu_result, aa_sync);
6633 /* If storage model access is required on the RHS, build the load. */
6634 else if (storage_model_access_required_p (gnat_node, &gnat_smo)
6635 && Present (Storage_Model_Copy_From (gnat_smo))
6636 && !present_in_lhs_or_actual_p (gnat_node))
6637 gnu_result = build_storage_model_load (gnat_smo, gnu_result);
6638 break;
6640 case N_Indexed_Component:
6642 const Entity_Id gnat_array_object = Prefix (gnat_node);
6643 tree gnu_array_object = gnat_to_gnu (gnat_array_object);
6644 tree gnu_type;
6645 int ndim, i;
6646 Node_Id *gnat_expr_array;
6648 /* Get the storage model of the array. */
6649 gnat_smo = get_storage_model (gnat_array_object);
6651 gnu_array_object = maybe_padded_object (gnu_array_object);
6652 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6654 /* Convert vector inputs to their representative array type, to fit
6655 what the code below expects. */
6656 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object)))
6658 if (present_in_lhs_or_actual_p (gnat_node))
6659 gnat_mark_addressable (gnu_array_object);
6660 gnu_array_object = maybe_vector_array (gnu_array_object);
6663 /* The failure of this assertion will very likely come from a missing
6664 expansion for a packed array access. */
6665 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
6667 /* First compute the number of dimensions of the array, then
6668 fill the expression array, the order depending on whether
6669 this is a Convention_Fortran array or not. */
6670 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
6671 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6672 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
6673 ndim++, gnu_type = TREE_TYPE (gnu_type))
6676 gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
6678 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
6679 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
6680 i >= 0;
6681 i--, gnat_temp = Next (gnat_temp))
6682 gnat_expr_array[i] = gnat_temp;
6683 else
6684 for (i = 0, gnat_temp = First (Expressions (gnat_node));
6685 i < ndim;
6686 i++, gnat_temp = Next (gnat_temp))
6687 gnat_expr_array[i] = gnat_temp;
6689 /* Start with the prefix and build the successive references. */
6690 gnu_result = gnu_array_object;
6692 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
6693 i < ndim;
6694 i++, gnu_type = TREE_TYPE (gnu_type))
6696 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
6697 gnat_temp = gnat_expr_array[i];
6698 gnu_expr = maybe_character_value (gnat_to_gnu (gnat_temp));
6700 gnu_result
6701 = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
6703 if (Present (gnat_smo))
6704 instantiate_load_in_array_ref (gnu_result, gnat_smo);
6707 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6709 /* If atomic access is required on the RHS, build the atomic load. */
6710 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6711 && !present_in_lhs_or_actual_p (gnat_node))
6712 gnu_result = build_atomic_load (gnu_result, aa_sync);
6714 /* If storage model access is required on the RHS, build the load. */
6715 else if (storage_model_access_required_p (gnat_node, &gnat_smo)
6716 && Present (Storage_Model_Copy_From (gnat_smo))
6717 && !present_in_lhs_or_actual_p (gnat_node))
6718 gnu_result = build_storage_model_load (gnat_smo, gnu_result);
6720 break;
6722 case N_Slice:
6724 const Entity_Id gnat_array_object = Prefix (gnat_node);
6725 tree gnu_array_object = gnat_to_gnu (gnat_array_object);
6727 /* Get the storage model of the array. */
6728 gnat_smo = get_storage_model (gnat_array_object);
6730 gnu_array_object = maybe_padded_object (gnu_array_object);
6731 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6733 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6735 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6736 gnu_expr = maybe_character_value (gnu_expr);
6738 /* If this is a slice with non-constant size of an array with constant
6739 size, set the maximum size for the allocation of temporaries. */
6740 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
6741 && TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object))))
6742 TYPE_ARRAY_MAX_SIZE (gnu_result_type)
6743 = TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object));
6745 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
6746 gnu_array_object, gnu_expr);
6748 if (Present (gnat_smo))
6749 instantiate_load_in_array_ref (gnu_result, gnat_smo);
6751 /* If storage model access is required on the RHS, build the load. */
6752 if (storage_model_access_required_p (gnat_node, &gnat_smo)
6753 && Present (Storage_Model_Copy_From (gnat_smo))
6754 && !present_in_lhs_or_actual_p (gnat_node))
6755 gnu_result = build_storage_model_load (gnat_smo, gnu_result);
6757 break;
6759 case N_Selected_Component:
6761 const Entity_Id gnat_prefix = Prefix (gnat_node);
6762 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
6763 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
6765 gnu_prefix = maybe_padded_object (gnu_prefix);
6767 /* gnat_to_gnu_entity does not save the GNU tree made for renamed
6768 discriminants so avoid making recursive calls on each reference
6769 to them by following the appropriate link directly here. */
6770 if (Ekind (gnat_field) == E_Discriminant)
6772 /* For discriminant references in tagged types always substitute
6773 the corresponding discriminant as the actual component. */
6774 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix))))
6775 while (Present (Corresponding_Discriminant (gnat_field)))
6776 gnat_field = Corresponding_Discriminant (gnat_field);
6778 /* For discriminant references in untagged types always substitute
6779 the corresponding stored discriminant. */
6780 else if (Present (Corresponding_Discriminant (gnat_field)))
6781 gnat_field = Original_Record_Component (gnat_field);
6784 /* Handle extracting the real or imaginary part of a complex.
6785 The real part is the first field and the imaginary the last. */
6786 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
6787 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
6788 ? REALPART_EXPR : IMAGPART_EXPR,
6789 NULL_TREE, gnu_prefix);
6790 else
6792 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
6793 tree gnu_offset;
6794 struct loop_info_d *loop;
6796 gnu_result
6797 = build_component_ref (gnu_prefix, gnu_field,
6798 (Nkind (Parent (gnat_node))
6799 == N_Attribute_Reference)
6800 && lvalue_required_for_attribute_p
6801 (Parent (gnat_node)));
6803 /* If optimization is enabled and we are inside a loop, we try to
6804 hoist nonconstant but invariant offset computations outside of
6805 the loop, since they very likely contain loads that could turn
6806 out to be hard to move if they end up in active EH regions. */
6807 if (optimize
6808 && inside_loop_p ()
6809 && TREE_CODE (gnu_result) == COMPONENT_REF
6810 && (gnu_offset = component_ref_field_offset (gnu_result))
6811 && !TREE_CONSTANT (gnu_offset)
6812 && (gnu_offset = gnat_invariant_expr (gnu_offset))
6813 && (loop = find_loop ()))
6815 tree invariant
6816 = build1 (SAVE_EXPR, TREE_TYPE (gnu_offset), gnu_offset);
6817 vec_safe_push (loop->invariants, invariant);
6818 tree field = TREE_OPERAND (gnu_result, 1);
6819 tree factor
6820 = size_int (DECL_OFFSET_ALIGN (field) / BITS_PER_UNIT);
6821 /* Divide the offset by its alignment. */
6822 TREE_OPERAND (gnu_result, 2)
6823 = size_binop (EXACT_DIV_EXPR, invariant, factor);
6827 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6829 /* If atomic access is required on the RHS, build the atomic load. */
6830 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6831 && !present_in_lhs_or_actual_p (gnat_node))
6832 gnu_result = build_atomic_load (gnu_result, aa_sync);
6834 /* If storage model access is required on the RHS, build the load. */
6835 else if (storage_model_access_required_p (gnat_node, &gnat_smo)
6836 && Present (Storage_Model_Copy_From (gnat_smo))
6837 && !present_in_lhs_or_actual_p (gnat_node))
6838 gnu_result = build_storage_model_load (gnat_smo, gnu_result);
6840 break;
6842 case N_Attribute_Reference:
6844 /* The attribute designator. */
6845 const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
6847 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6848 is a unit, not an object with a GCC equivalent. */
6849 if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
6850 return
6851 create_subprog_decl (create_concat_name
6852 (Entity (Prefix (gnat_node)),
6853 attr == Attr_Elab_Body ? "elabb" : "elabs"),
6854 NULL_TREE, void_ftype, NULL_TREE, is_default,
6855 true, true, true, true, false, NULL,
6856 gnat_node);
6858 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
6860 break;
6862 case N_Reference:
6863 /* Like 'Access as far as we are concerned. */
6864 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6865 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6866 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6867 break;
6869 case N_Aggregate:
6870 case N_Extension_Aggregate:
6872 tree gnu_aggr_type;
6874 /* Check that this aggregate has not slipped through the cracks. */
6875 gcc_assert (!Expansion_Delayed (gnat_node));
6877 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6879 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
6880 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
6881 gnu_aggr_type
6882 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type)));
6883 else if (VECTOR_TYPE_P (gnu_result_type))
6884 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
6885 else
6886 gnu_aggr_type = gnu_result_type;
6888 if (Null_Record_Present (gnat_node))
6889 gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
6891 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
6892 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
6893 gnu_result
6894 = assoc_to_constructor (Etype (gnat_node),
6895 First (Component_Associations (gnat_node)),
6896 gnu_aggr_type);
6897 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
6898 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
6899 gnu_aggr_type);
6900 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
6901 gnu_result
6902 = build_binary_op
6903 (COMPLEX_EXPR, gnu_aggr_type,
6904 gnat_to_gnu (Expression (First
6905 (Component_Associations (gnat_node)))),
6906 gnat_to_gnu (Expression
6907 (Next
6908 (First (Component_Associations (gnat_node))))));
6909 else
6910 gcc_unreachable ();
6912 gnu_result = convert (gnu_result_type, gnu_result);
6914 break;
6916 case N_Null:
6917 if (TARGET_VTABLE_USES_DESCRIPTORS
6918 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
6919 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
6920 gnu_result = null_fdesc_node;
6921 else
6922 gnu_result = null_pointer_node;
6923 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6924 break;
6926 case N_Type_Conversion:
6927 case N_Qualified_Expression:
6928 gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
6929 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6931 /* If this is a qualified expression for a tagged type, we mark the type
6932 as used. Because of polymorphism, this might be the only reference to
6933 the tagged type in the program while objects have it as dynamic type.
6934 The debugger needs to see it to display these objects properly. */
6935 if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
6936 used_types_insert (gnu_result_type);
6938 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node)));
6940 gnu_result
6941 = convert_with_check (Etype (gnat_node), gnu_expr,
6942 Do_Overflow_Check (gnat_node),
6943 kind == N_Type_Conversion
6944 && Float_Truncate (gnat_node), gnat_node);
6945 break;
6947 case N_Unchecked_Type_Conversion:
6948 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6949 gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
6951 /* Skip further processing if the conversion is deemed a no-op. */
6952 if (unchecked_conversion_nop (gnat_node))
6954 gnu_result = gnu_expr;
6955 gnu_result_type = TREE_TYPE (gnu_result);
6956 break;
6959 /* If the result is a pointer type, see if we are improperly
6960 converting to a stricter alignment. */
6961 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
6962 && Is_Access_Type (Etype (gnat_node)))
6964 unsigned int align = known_alignment (gnu_expr);
6965 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
6966 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
6968 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
6969 post_error_ne_tree_2
6970 ("??source alignment (^) '< alignment of & (^)",
6971 gnat_node, Designated_Type (Etype (gnat_node)),
6972 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
6975 /* If we are converting a descriptor to a function pointer, first
6976 build the pointer. */
6977 if (TARGET_VTABLE_USES_DESCRIPTORS
6978 && TREE_TYPE (gnu_expr) == fdesc_type_node
6979 && POINTER_TYPE_P (gnu_result_type))
6980 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
6982 gnu_result = unchecked_convert (gnu_result_type, gnu_expr,
6983 No_Truncation (gnat_node));
6984 break;
6986 case N_In:
6987 case N_Not_In:
6989 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
6990 tree gnu_low, gnu_high;
6992 Range_to_gnu (Right_Opnd (gnat_node), &gnu_low, &gnu_high);
6993 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6995 tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_obj));
6996 if (TREE_TYPE (gnu_obj) != gnu_op_type)
6998 gnu_obj = convert (gnu_op_type, gnu_obj);
6999 gnu_low = convert (gnu_op_type, gnu_low);
7000 gnu_high = convert (gnu_op_type, gnu_high);
7003 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
7004 ensure that GNU_OBJ is evaluated only once and perform a full range
7005 test. */
7006 if (operand_equal_p (gnu_low, gnu_high, 0))
7007 gnu_result
7008 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
7009 else
7011 tree t1, t2;
7012 gnu_obj = gnat_protect_expr (gnu_obj);
7013 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
7014 if (EXPR_P (t1))
7015 set_expr_location_from_node (t1, gnat_node);
7016 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
7017 if (EXPR_P (t2))
7018 set_expr_location_from_node (t2, gnat_node);
7019 gnu_result
7020 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
7023 if (kind == N_Not_In)
7024 gnu_result
7025 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
7027 break;
7029 case N_Op_Divide:
7030 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
7031 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
7032 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7033 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
7034 ? RDIV_EXPR
7035 : (Rounded_Result (gnat_node)
7036 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
7037 gnu_result_type, gnu_lhs, gnu_rhs);
7038 /* If the result type is larger than a word, then declare the dependence
7039 on the libgcc routine. */
7040 if (INTEGRAL_TYPE_P (gnu_result_type)
7041 && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD)
7042 Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node);
7043 break;
7045 case N_Op_Eq:
7046 case N_Op_Ne:
7047 case N_Op_Lt:
7048 case N_Op_Le:
7049 case N_Op_Gt:
7050 case N_Op_Ge:
7051 case N_Op_Add:
7052 case N_Op_Subtract:
7053 case N_Op_Multiply:
7054 case N_Op_Mod:
7055 case N_Op_Rem:
7056 case N_Op_Rotate_Left:
7057 case N_Op_Rotate_Right:
7058 case N_Op_Shift_Left:
7059 case N_Op_Shift_Right:
7060 case N_Op_Shift_Right_Arithmetic:
7061 case N_Op_And:
7062 case N_Op_Or:
7063 case N_Op_Xor:
7064 case N_And_Then:
7065 case N_Or_Else:
7067 enum tree_code code = gnu_codes[kind];
7068 bool ignore_lhs_overflow = false;
7069 location_t saved_location = input_location;
7070 tree gnu_type, gnu_max_shift = NULL_TREE;
7072 /* Fix operations set up for boolean types in GNU_CODES above. */
7073 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
7074 switch (kind)
7076 case N_Op_And:
7077 code = BIT_AND_EXPR;
7078 break;
7079 case N_Op_Or:
7080 code = BIT_IOR_EXPR;
7081 break;
7082 case N_Op_Xor:
7083 code = BIT_XOR_EXPR;
7084 break;
7085 default:
7086 break;
7089 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
7090 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
7091 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
7093 /* If this is a shift, take the count as unsigned since that is what
7094 most machines do and will generate simpler adjustments below. */
7095 if (IN (kind, N_Op_Shift))
7097 tree gnu_count_type
7098 = gnat_unsigned_type_for (get_base_type (TREE_TYPE (gnu_rhs)));
7099 gnu_rhs = convert (gnu_count_type, gnu_rhs);
7100 gnu_max_shift
7101 = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type));
7102 /* If the result type is larger than a word, then declare the dependence
7103 on the libgcc routine. */
7104 if (TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD)
7105 Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node);
7108 /* If this is a comparison between (potentially) large aggregates, then
7109 declare the dependence on the memcmp routine. */
7110 else if ((kind == N_Op_Eq || kind == N_Op_Ne)
7111 && AGGREGATE_TYPE_P (TREE_TYPE (gnu_lhs))
7112 && (!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_lhs)))
7113 || compare_tree_int (TYPE_SIZE (TREE_TYPE (gnu_lhs)),
7114 2 * BITS_PER_WORD) > 0))
7115 Check_Restriction_No_Dependence_On_System (Name_Memory_Compare,
7116 gnat_node);
7118 /* If this is a modulo/remainder and the result type is larger than a
7119 word, then declare the dependence on the libgcc routine. */
7120 else if ((kind == N_Op_Mod ||kind == N_Op_Rem)
7121 && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD)
7122 Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node);
7124 /* Pending generic support for efficient vector logical operations in
7125 GCC, convert vectors to their representative array type view. */
7126 gnu_lhs = maybe_vector_array (gnu_lhs);
7127 gnu_rhs = maybe_vector_array (gnu_rhs);
7129 /* If this is a comparison operator, convert any references to an
7130 unconstrained array value into a reference to the actual array. */
7131 if (TREE_CODE_CLASS (code) == tcc_comparison)
7133 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
7134 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
7136 tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_lhs));
7137 if (TREE_TYPE (gnu_lhs) != gnu_op_type)
7139 gnu_lhs = convert (gnu_op_type, gnu_lhs);
7140 gnu_rhs = convert (gnu_op_type, gnu_rhs);
7144 /* If this is a shift whose count is not guaranteed to be correct,
7145 we need to adjust the shift count. */
7146 if ((kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
7147 && !Shift_Count_OK (gnat_node))
7148 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, TREE_TYPE (gnu_rhs),
7149 gnu_rhs, gnu_max_shift);
7150 else if (kind == N_Op_Shift_Right_Arithmetic
7151 && !Shift_Count_OK (gnat_node))
7152 gnu_rhs
7153 = build_binary_op (MIN_EXPR, TREE_TYPE (gnu_rhs),
7154 build_binary_op (MINUS_EXPR,
7155 TREE_TYPE (gnu_rhs),
7156 gnu_max_shift,
7157 build_int_cst
7158 (TREE_TYPE (gnu_rhs), 1)),
7159 gnu_rhs);
7161 /* For right shifts, the type says what kind of shift to do,
7162 so we may need to choose a different type. In this case,
7163 we have to ignore integer overflow lest it propagates all
7164 the way down and causes a CE to be explicitly raised. */
7165 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
7167 gnu_type = gnat_unsigned_type_for (gnu_type);
7168 ignore_lhs_overflow = true;
7170 else if (kind == N_Op_Shift_Right_Arithmetic
7171 && TYPE_UNSIGNED (gnu_type))
7173 gnu_type = gnat_signed_type_for (gnu_type);
7174 ignore_lhs_overflow = true;
7177 if (gnu_type != gnu_result_type)
7179 tree gnu_old_lhs = gnu_lhs;
7180 gnu_lhs = convert (gnu_type, gnu_lhs);
7181 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
7182 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
7183 gnu_rhs = convert (gnu_type, gnu_rhs);
7184 if (gnu_max_shift)
7185 gnu_max_shift = convert (gnu_type, gnu_max_shift);
7188 /* For signed integer addition, subtraction and multiplication, do an
7189 overflow check if required. */
7190 if (Do_Overflow_Check (gnat_node)
7191 && (code == PLUS_EXPR || code == MINUS_EXPR || code == MULT_EXPR)
7192 && !TYPE_UNSIGNED (gnu_type)
7193 && !FLOAT_TYPE_P (gnu_type))
7194 gnu_result
7195 = build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs,
7196 gnat_node);
7197 else
7199 /* Some operations, e.g. comparisons of arrays, generate complex
7200 trees that need to be annotated while they are being built. */
7201 input_location = saved_location;
7202 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
7205 /* If this is a logical shift with the shift count not verified,
7206 we must return zero if it is too large. We cannot compensate
7207 beforehand in this case. */
7208 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
7209 && !Shift_Count_OK (gnat_node))
7210 gnu_result
7211 = build_cond_expr (gnu_type,
7212 build_binary_op (GE_EXPR, boolean_type_node,
7213 gnu_rhs, gnu_max_shift),
7214 build_int_cst (gnu_type, 0),
7215 gnu_result);
7217 break;
7219 case N_If_Expression:
7221 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
7222 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
7223 tree gnu_false
7224 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
7226 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7227 gnu_result
7228 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
7230 break;
7232 case N_Op_Plus:
7233 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
7234 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7235 break;
7237 case N_Op_Not:
7238 /* This case can apply to a boolean or a modular type.
7239 Fall through for a boolean operand since GNU_CODES is set
7240 up to handle this. */
7241 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
7243 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
7244 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7245 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
7246 gnu_expr);
7247 break;
7250 /* ... fall through ... */
7252 case N_Op_Minus:
7253 case N_Op_Abs:
7254 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
7255 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7257 /* For signed integer negation and absolute value, do an overflow check
7258 if required. */
7259 if (Do_Overflow_Check (gnat_node)
7260 && !TYPE_UNSIGNED (gnu_result_type)
7261 && !FLOAT_TYPE_P (gnu_result_type))
7262 gnu_result
7263 = build_unary_op_trapv (gnu_codes[kind], gnu_result_type, gnu_expr,
7264 gnat_node);
7265 else
7266 gnu_result
7267 = build_unary_op (gnu_codes[kind], gnu_result_type, gnu_expr);
7268 break;
7270 case N_Allocator:
7272 tree gnu_type, gnu_init;
7273 bool ignore_init_type;
7275 gnat_temp = Expression (gnat_node);
7277 /* The expression can be either an N_Identifier or an Expanded_Name,
7278 which must represent a type, or a N_Qualified_Expression, which
7279 contains both the type and an initial value for the object. */
7280 if (Nkind (gnat_temp) == N_Identifier
7281 || Nkind (gnat_temp) == N_Expanded_Name)
7283 ignore_init_type = false;
7284 gnu_init = NULL_TREE;
7285 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
7288 else if (Nkind (gnat_temp) == N_Qualified_Expression)
7290 const Entity_Id gnat_desig_type
7291 = Designated_Type (Underlying_Type (Etype (gnat_node)));
7293 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
7295 gnu_init = gnat_to_gnu (Expression (gnat_temp));
7296 gnu_init = maybe_unconstrained_array (gnu_init);
7298 gigi_checking_assert (!Do_Range_Check (Expression (gnat_temp)));
7300 if (Is_Elementary_Type (gnat_desig_type)
7301 || Is_Constrained (gnat_desig_type))
7302 gnu_type = gnat_to_gnu_type (gnat_desig_type);
7303 else
7305 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
7306 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
7307 gnu_type = TREE_TYPE (gnu_init);
7310 /* See the N_Qualified_Expression case for the rationale. */
7311 if (Is_Tagged_Type (gnat_desig_type))
7312 used_types_insert (gnu_type);
7314 gnu_init = convert (gnu_type, gnu_init);
7316 else
7317 gcc_unreachable ();
7319 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7320 return build_allocator (gnu_type, gnu_init, gnu_result_type,
7321 Procedure_To_Call (gnat_node),
7322 Storage_Pool (gnat_node), gnat_node,
7323 ignore_init_type);
7325 break;
7327 /**************************/
7328 /* Chapter 5: Statements */
7329 /**************************/
7331 case N_Label:
7332 gnu_result = build1 (LABEL_EXPR, void_type_node,
7333 gnat_to_gnu (Identifier (gnat_node)));
7334 break;
7336 case N_Null_Statement:
7337 /* When not optimizing, turn null statements from source into gotos to
7338 the next statement that the middle-end knows how to preserve. */
7339 if (!optimize && Comes_From_Source (gnat_node))
7341 tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
7342 DECL_IGNORED_P (label) = 1;
7343 start_stmt_group ();
7344 stmt = build1 (GOTO_EXPR, void_type_node, label);
7345 set_expr_location_from_node (stmt, gnat_node);
7346 add_stmt (stmt);
7347 stmt = build1 (LABEL_EXPR, void_type_node, label);
7348 set_expr_location_from_node (stmt, gnat_node);
7349 add_stmt (stmt);
7350 gnu_result = end_stmt_group ();
7352 else
7353 gnu_result = alloc_stmt_list ();
7354 break;
7356 case N_Assignment_Statement:
7357 /* First get the LHS of the statement and convert any reference to an
7358 unconstrained array into a reference to the underlying array. */
7359 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
7361 /* If the type has a size that overflows, convert this into raise of
7362 Storage_Error: execution shouldn't have gotten here anyway. */
7363 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
7364 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
7365 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
7366 N_Raise_Storage_Error);
7368 /* If the RHS is a function call, let Call_to_gnu do the entire work. */
7369 else if (Nkind (Expression (gnat_node)) == N_Function_Call)
7371 get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
7372 get_storage_model_access (Name (gnat_node), &gnat_smo);
7373 gnu_result
7374 = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
7375 aa_type, aa_sync, gnat_smo);
7378 /* Otherwise we need to build the assignment statement manually. */
7379 else
7381 const Node_Id gnat_expr = Expression (gnat_node);
7382 const Node_Id gnat_inner
7383 = Nkind (gnat_expr) == N_Qualified_Expression
7384 ? Expression (gnat_expr)
7385 : gnat_expr;
7386 const Entity_Id gnat_type
7387 = Underlying_Type (Etype (Name (gnat_node)));
7388 const bool use_memset_p
7389 = Is_Array_Type (gnat_type)
7390 && Nkind (gnat_inner) == N_Aggregate
7391 && Is_Single_Aggregate (gnat_inner);
7393 /* If we use memset, we need to find the innermost expression. */
7394 if (use_memset_p)
7396 gnat_temp = gnat_inner;
7397 do {
7398 gnat_temp
7399 = Expression (First (Component_Associations (gnat_temp)));
7400 } while (Nkind (gnat_temp) == N_Aggregate
7401 && Is_Single_Aggregate (gnat_temp));
7402 gnu_rhs = gnat_to_gnu (gnat_temp);
7405 /* Otherwise get the RHS of the statement and do the same processing
7406 as for the LHS above. */
7407 else
7408 gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
7410 gigi_checking_assert (!Do_Range_Check (gnat_expr));
7412 get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
7413 get_storage_model_access (Name (gnat_node), &gnat_smo);
7415 /* If an outer atomic access is required on the LHS, build the load-
7416 modify-store sequence. */
7417 if (aa_type == OUTER_ATOMIC)
7418 gnu_result = build_load_modify_store (gnu_lhs, gnu_rhs, gnat_node);
7420 /* Or else, if a simple atomic access is required, build the atomic
7421 store. */
7422 else if (aa_type == SIMPLE_ATOMIC)
7423 gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, aa_sync);
7425 /* Or else, if a storage model access is required, build the special
7426 store. */
7427 else if (Present (gnat_smo)
7428 && Present (Storage_Model_Copy_To (gnat_smo)))
7430 /* We obviously cannot use memset in this case. */
7431 gcc_assert (!use_memset_p);
7433 /* We cannot directly move between nonnative storage models. */
7434 tree t = remove_conversions (gnu_rhs, false);
7435 gcc_assert (TREE_CODE (t) != LOAD_EXPR);
7437 gnu_result
7438 = build_storage_model_store (gnat_smo, gnu_lhs, gnu_rhs);
7441 /* Or else, use memset when the conditions are met. This has already
7442 been validated by Aggr_Assignment_OK_For_Backend in the front-end
7443 and the RHS is thus guaranteed to be of the appropriate form. */
7444 else if (use_memset_p)
7446 tree value
7447 = real_zerop (gnu_rhs)
7448 ? integer_zero_node
7449 : fold_convert (integer_type_node, gnu_rhs);
7450 tree dest = build_fold_addr_expr (gnu_lhs);
7451 tree t = builtin_decl_explicit (BUILT_IN_MEMSET);
7452 /* Be extra careful not to write too much data. */
7453 tree size;
7454 if (TREE_CODE (gnu_lhs) == COMPONENT_REF)
7455 size = DECL_SIZE_UNIT (TREE_OPERAND (gnu_lhs, 1));
7456 else if (DECL_P (gnu_lhs))
7457 size = DECL_SIZE_UNIT (gnu_lhs);
7458 else
7459 size = TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs));
7460 size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_lhs);
7461 if (TREE_CODE (value) == INTEGER_CST && !integer_zerop (value))
7463 tree mask
7464 = build_int_cst (integer_type_node,
7465 ((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1);
7466 value = int_const_binop (BIT_AND_EXPR, value, mask);
7468 gnu_result = build_call_expr (t, 3, dest, value, size);
7469 Check_Restriction_No_Dependence_On_System (Name_Memory_Set,
7470 gnat_node);
7473 else
7475 tree t = remove_conversions (gnu_rhs, false);
7477 /* If a storage model load is present on the RHS, then elide the
7478 temporary associated with it. */
7479 if (TREE_CODE (t) == LOAD_EXPR)
7481 gnu_result = TREE_OPERAND (t, 1);
7482 gcc_assert (TREE_CODE (gnu_result) == CALL_EXPR);
7484 tree arg = CALL_EXPR_ARG (gnu_result, 1);
7485 CALL_EXPR_ARG (gnu_result, 1)
7486 = build_unary_op (ADDR_EXPR, TREE_TYPE (arg), gnu_lhs);
7489 /* Otherwise build a regular assignment. */
7490 else
7491 gnu_result
7492 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
7495 /* If the assignment type is a regular array and the two sides are
7496 not completely disjoint, play safe and use memmove. But don't do
7497 it for a bit-packed array as it might not be byte-aligned. */
7498 if (TREE_CODE (gnu_result) == MODIFY_EXPR
7499 && Is_Array_Type (gnat_type)
7500 && !Is_Bit_Packed_Array (gnat_type)
7501 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
7503 tree to = TREE_OPERAND (gnu_result, 0);
7504 tree from = TREE_OPERAND (gnu_result, 1);
7505 tree type = TREE_TYPE (from);
7506 tree size
7507 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from);
7508 tree to_ptr = build_fold_addr_expr (to);
7509 tree from_ptr = build_fold_addr_expr (from);
7510 tree t = builtin_decl_explicit (BUILT_IN_MEMMOVE);
7511 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
7512 Check_Restriction_No_Dependence_On_System (Name_Memory_Move,
7513 gnat_node);
7516 /* If this is an assignment between (potentially) large aggregates,
7517 then declare the dependence on the memcpy routine. */
7518 else if (AGGREGATE_TYPE_P (TREE_TYPE (gnu_lhs))
7519 && (!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_lhs)))
7520 || compare_tree_int (TYPE_SIZE (TREE_TYPE (gnu_lhs)),
7521 2 * BITS_PER_WORD) > 0))
7522 Check_Restriction_No_Dependence_On_System (Name_Memory_Copy,
7523 gnat_node);
7525 break;
7527 case N_If_Statement:
7529 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
7531 /* Make the outer COND_EXPR. Avoid non-determinism. */
7532 gnu_result = build3 (COND_EXPR, void_type_node,
7533 gnat_to_gnu (Condition (gnat_node)),
7534 NULL_TREE, NULL_TREE);
7535 COND_EXPR_THEN (gnu_result)
7536 = build_stmt_group (Then_Statements (gnat_node), false);
7537 TREE_SIDE_EFFECTS (gnu_result) = 1;
7538 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
7540 /* Now make a COND_EXPR for each of the "else if" parts. Put each
7541 into the previous "else" part and point to where to put any
7542 outer "else". Also avoid non-determinism. */
7543 if (Present (Elsif_Parts (gnat_node)))
7544 for (gnat_temp = First (Elsif_Parts (gnat_node));
7545 Present (gnat_temp); gnat_temp = Next (gnat_temp))
7547 gnu_expr = build3 (COND_EXPR, void_type_node,
7548 gnat_to_gnu (Condition (gnat_temp)),
7549 NULL_TREE, NULL_TREE);
7550 COND_EXPR_THEN (gnu_expr)
7551 = build_stmt_group (Then_Statements (gnat_temp), false);
7552 TREE_SIDE_EFFECTS (gnu_expr) = 1;
7553 set_expr_location_from_node (gnu_expr, gnat_temp);
7554 *gnu_else_ptr = gnu_expr;
7555 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
7558 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
7560 break;
7562 case N_Case_Statement:
7563 gnu_result = Case_Statement_to_gnu (gnat_node);
7564 break;
7566 case N_Loop_Statement:
7567 gnu_result = Loop_Statement_to_gnu (gnat_node);
7568 break;
7570 case N_Block_Statement:
7571 /* The only way to enter the block is to fall through to it. */
7572 if (stmt_group_may_fallthru ())
7574 start_stmt_group ();
7575 gnat_pushlevel ();
7576 process_decls (Declarations (gnat_node), Empty, true, true);
7577 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7578 if (Present (At_End_Proc (gnat_node)))
7579 At_End_Proc_to_gnu (gnat_node);
7580 gnat_poplevel ();
7581 gnu_result = end_stmt_group ();
7583 else
7584 gnu_result = alloc_stmt_list ();
7585 break;
7587 case N_Exit_Statement:
7588 gnu_result
7589 = build2 (EXIT_STMT, void_type_node,
7590 (Present (Condition (gnat_node))
7591 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
7592 (Present (Name (gnat_node))
7593 ? get_gnu_tree (Entity (Name (gnat_node)))
7594 : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt)));
7595 break;
7597 case N_Simple_Return_Statement:
7599 tree gnu_ret_obj, gnu_ret_val;
7601 /* If the subprogram is a function, we must return the expression. */
7602 if (Present (Expression (gnat_node)))
7604 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
7606 /* If this function has copy-in/copy-out parameters parameters and
7607 doesn't return by invisible reference, get the real object for
7608 the return. See Subprogram_Body_to_gnu. */
7609 if (TYPE_CI_CO_LIST (gnu_subprog_type)
7610 && !TREE_ADDRESSABLE (gnu_subprog_type))
7611 gnu_ret_obj = gnu_return_var_stack->last ();
7612 else
7613 gnu_ret_obj = DECL_RESULT (current_function_decl);
7615 /* Get the GCC tree for the expression to be returned. */
7616 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
7618 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7619 self-referential since we want to allocate the fixed size. */
7620 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
7621 && type_is_padding_self_referential
7622 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
7623 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
7625 /* If the function returns by direct reference, return a pointer
7626 to the return value, possibly after allocating it. */
7627 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
7629 if (Present (Storage_Pool (gnat_node)))
7631 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
7633 /* And find out whether it is a candidate for Named Return
7634 Value. If so, record it. */
7635 if (optimize
7636 && !optimize_debug
7637 && !TYPE_CI_CO_LIST (gnu_subprog_type))
7639 tree ret_val = gnu_ret_val;
7641 /* Strip conversions around the return value. */
7642 if (gnat_useless_type_conversion (ret_val))
7643 ret_val = TREE_OPERAND (ret_val, 0);
7645 /* Strip unpadding around the return value. */
7646 if (TREE_CODE (ret_val) == COMPONENT_REF
7647 && TYPE_IS_PADDING_P
7648 (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
7649 ret_val = TREE_OPERAND (ret_val, 0);
7651 /* Now apply the test to the return value. */
7652 if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
7654 if (!f_named_ret_val)
7655 f_named_ret_val = BITMAP_GGC_ALLOC ();
7656 bitmap_set_bit (f_named_ret_val,
7657 DECL_UID (ret_val));
7658 if (!f_gnat_ret)
7659 f_gnat_ret = gnat_node;
7663 gnu_ret_val
7664 = build_allocator (TREE_TYPE (gnu_ret_val),
7665 gnu_ret_val,
7666 TREE_TYPE (gnu_ret_obj),
7667 Procedure_To_Call (gnat_node),
7668 Storage_Pool (gnat_node),
7669 gnat_node,
7670 false);
7673 else
7674 gnu_ret_val
7675 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
7678 /* Otherwise, if it returns by invisible reference, dereference
7679 the pointer it is passed using the type of the return value
7680 and build the copy operation manually. This ensures that we
7681 don't copy too much data, for example if the return type is
7682 unconstrained with a maximum size. */
7683 else if (TREE_ADDRESSABLE (gnu_subprog_type))
7685 tree gnu_ret_deref
7686 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
7687 gnu_ret_obj);
7688 gnu_result = build2 (INIT_EXPR, void_type_node,
7689 gnu_ret_deref, gnu_ret_val);
7690 /* Avoid a useless copy with __builtin_return_slot. */
7691 if (INDIRECT_REF_P (gnu_ret_val))
7692 gnu_result
7693 = build3 (COND_EXPR, void_type_node,
7694 fold_build2 (NE_EXPR, boolean_type_node,
7695 TREE_OPERAND (gnu_ret_val, 0),
7696 gnu_ret_obj),
7697 gnu_result, NULL_TREE);
7698 add_stmt_with_node (gnu_result, gnat_node);
7699 gnu_ret_val = NULL_TREE;
7703 else
7704 gnu_ret_obj = gnu_ret_val = NULL_TREE;
7706 /* If we have a return label defined, convert this into a branch to
7707 that label. The return proper will be handled elsewhere. */
7708 if (gnu_return_label_stack->last ())
7710 if (gnu_ret_val)
7711 add_stmt_with_node (build_binary_op (MODIFY_EXPR,
7712 NULL_TREE, gnu_ret_obj,
7713 gnu_ret_val),
7714 gnat_node);
7716 gnu_result = build1 (GOTO_EXPR, void_type_node,
7717 gnu_return_label_stack->last ());
7719 /* When not optimizing, make sure the return is preserved. */
7720 if (!optimize && Comes_From_Source (gnat_node))
7721 DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0;
7724 /* Otherwise, build a regular return. */
7725 else
7726 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
7728 break;
7730 case N_Goto_Statement:
7731 gnu_expr = gnat_to_gnu (Name (gnat_node));
7732 gnu_result = build1 (GOTO_EXPR, void_type_node, gnu_expr);
7733 TREE_USED (gnu_expr) = 1;
7734 break;
7736 /***************************/
7737 /* Chapter 6: Subprograms */
7738 /***************************/
7740 case N_Subprogram_Declaration:
7741 /* Unless there is a freeze node, declare the entity. We consider
7742 this a definition even though we're not generating code for the
7743 subprogram because we will be making the corresponding GCC node.
7744 When there is a freeze node, it is considered the definition of
7745 the subprogram and we do nothing until after it is encountered.
7746 That's an efficiency issue: the types involved in the profile
7747 are far more likely to be frozen between the declaration and
7748 the freeze node than before the declaration, so we save some
7749 updates of the GCC node by waiting until the freeze node.
7750 The counterpart is that we assume that there is no reference
7751 to the subprogram between the declaration and the freeze node
7752 in the expanded code; otherwise, it will be interpreted as an
7753 external reference and very likely give rise to a link failure. */
7754 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7755 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
7756 NULL_TREE, true);
7757 gnu_result = alloc_stmt_list ();
7758 break;
7760 case N_Abstract_Subprogram_Declaration:
7761 /* This subprogram doesn't exist for code generation purposes, but we
7762 have to elaborate the types of any parameters and result, unless
7763 they are imported types (nothing to generate in this case).
7765 The parameter list may contain types with freeze nodes, e.g. not null
7766 subtypes, so the subprogram itself may carry a freeze node, in which
7767 case its elaboration must be deferred. */
7769 /* Process the parameter types first. */
7770 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7771 for (gnat_temp
7772 = First_Formal_With_Extras
7773 (Defining_Entity (Specification (gnat_node)));
7774 Present (gnat_temp);
7775 gnat_temp = Next_Formal_With_Extras (gnat_temp))
7776 if (Is_Itype (Etype (gnat_temp))
7777 && !From_Limited_With (Etype (gnat_temp)))
7778 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
7780 /* Then the result type, set to Standard_Void_Type for procedures. */
7782 Entity_Id gnat_temp_type
7783 = Etype (Defining_Entity (Specification (gnat_node)));
7785 if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type))
7786 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, false);
7789 gnu_result = alloc_stmt_list ();
7790 break;
7792 case N_Defining_Program_Unit_Name:
7793 /* For a child unit identifier go up a level to get the specification.
7794 We get this when we try to find the spec of a child unit package
7795 that is the compilation unit being compiled. */
7796 gnu_result = gnat_to_gnu (Parent (gnat_node));
7797 break;
7799 case N_Subprogram_Body:
7800 Subprogram_Body_to_gnu (gnat_node);
7801 gnu_result = alloc_stmt_list ();
7802 break;
7804 case N_Function_Call:
7805 case N_Procedure_Call_Statement:
7806 gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
7807 NOT_ATOMIC, false, Empty);
7808 break;
7810 /************************/
7811 /* Chapter 7: Packages */
7812 /************************/
7814 case N_Package_Declaration:
7815 gnu_result = gnat_to_gnu (Specification (gnat_node));
7816 break;
7818 case N_Package_Specification:
7819 start_stmt_group ();
7820 process_decls (Visible_Declarations (gnat_node),
7821 Private_Declarations (gnat_node),
7822 true, true);
7823 gnu_result = end_stmt_group ();
7824 break;
7826 case N_Package_Body:
7827 /* If this is the body of a generic package - do nothing. */
7828 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
7830 gnu_result = alloc_stmt_list ();
7831 break;
7834 start_stmt_group ();
7835 process_decls (Declarations (gnat_node), Empty, true, true);
7836 if (Present (Handled_Statement_Sequence (gnat_node)))
7837 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7838 if (Present (At_End_Proc (gnat_node)))
7839 At_End_Proc_to_gnu (gnat_node);
7840 gnu_result = end_stmt_group ();
7841 break;
7843 /********************************/
7844 /* Chapter 8: Visibility Rules */
7845 /********************************/
7847 case N_Use_Package_Clause:
7848 case N_Use_Type_Clause:
7849 /* Nothing to do here - but these may appear in list of declarations. */
7850 gnu_result = alloc_stmt_list ();
7851 break;
7853 /*********************/
7854 /* Chapter 9: Tasks */
7855 /*********************/
7857 case N_Protected_Type_Declaration:
7858 gnu_result = alloc_stmt_list ();
7859 break;
7861 case N_Single_Task_Declaration:
7862 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
7863 gnu_result = alloc_stmt_list ();
7864 break;
7866 /*********************************************************/
7867 /* Chapter 10: Program Structure and Compilation Issues */
7868 /*********************************************************/
7870 case N_Compilation_Unit:
7871 /* This is not called for the main unit on which gigi is invoked. */
7872 Compilation_Unit_to_gnu (gnat_node);
7873 gnu_result = alloc_stmt_list ();
7874 break;
7876 case N_Subunit:
7877 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
7878 break;
7880 case N_Entry_Body:
7881 case N_Protected_Body:
7882 case N_Task_Body:
7883 /* These nodes should only be present when annotating types. */
7884 gcc_assert (type_annotate_only);
7885 process_decls (Declarations (gnat_node), Empty, true, true);
7886 gnu_result = alloc_stmt_list ();
7887 break;
7889 case N_Subprogram_Body_Stub:
7890 case N_Package_Body_Stub:
7891 case N_Protected_Body_Stub:
7892 case N_Task_Body_Stub:
7893 /* Simply process whatever unit is being inserted. */
7894 if (Present (Library_Unit (gnat_node)))
7895 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
7896 else
7898 gcc_assert (type_annotate_only);
7899 gnu_result = alloc_stmt_list ();
7901 break;
7903 /***************************/
7904 /* Chapter 11: Exceptions */
7905 /***************************/
7907 case N_Handled_Sequence_Of_Statements:
7908 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
7909 break;
7911 case N_Exception_Handler:
7912 gnu_result = Exception_Handler_to_gnu (gnat_node);
7913 break;
7915 case N_Raise_Statement:
7916 /* Only for reraise in back-end exceptions mode. */
7917 gcc_assert (No (Name (gnat_node)));
7919 start_stmt_group ();
7921 add_stmt_with_node (build_call_n_expr (reraise_zcx_decl, 1,
7922 gnu_incoming_exc_ptr),
7923 gnat_node);
7925 gnu_result = end_stmt_group ();
7926 break;
7928 case N_Push_Constraint_Error_Label:
7929 gnu_constraint_error_label_stack.safe_push (Exception_Label (gnat_node));
7930 break;
7932 case N_Push_Storage_Error_Label:
7933 gnu_storage_error_label_stack.safe_push (Exception_Label (gnat_node));
7934 break;
7936 case N_Push_Program_Error_Label:
7937 gnu_program_error_label_stack.safe_push (Exception_Label (gnat_node));
7938 break;
7940 case N_Pop_Constraint_Error_Label:
7941 gnat_temp = gnu_constraint_error_label_stack.pop ();
7942 if (Present (gnat_temp)
7943 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))
7944 && No_Exception_Propagation_Active ())
7945 Warn_If_No_Local_Raise (gnat_temp);
7946 break;
7948 case N_Pop_Storage_Error_Label:
7949 gnat_temp = gnu_storage_error_label_stack.pop ();
7950 if (Present (gnat_temp)
7951 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))
7952 && No_Exception_Propagation_Active ())
7953 Warn_If_No_Local_Raise (gnat_temp);
7954 break;
7956 case N_Pop_Program_Error_Label:
7957 gnat_temp = gnu_program_error_label_stack.pop ();
7958 if (Present (gnat_temp)
7959 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))
7960 && No_Exception_Propagation_Active ())
7961 Warn_If_No_Local_Raise (gnat_temp);
7962 break;
7964 /******************************/
7965 /* Chapter 12: Generic Units */
7966 /******************************/
7968 case N_Generic_Function_Renaming_Declaration:
7969 case N_Generic_Package_Renaming_Declaration:
7970 case N_Generic_Procedure_Renaming_Declaration:
7971 case N_Generic_Package_Declaration:
7972 case N_Generic_Subprogram_Declaration:
7973 case N_Package_Instantiation:
7974 case N_Procedure_Instantiation:
7975 case N_Function_Instantiation:
7976 /* These nodes can appear on a declaration list but there is nothing to
7977 to be done with them. */
7978 gnu_result = alloc_stmt_list ();
7979 break;
7981 /**************************************************/
7982 /* Chapter 13: Representation Clauses and */
7983 /* Implementation-Dependent Features */
7984 /**************************************************/
7986 case N_Attribute_Definition_Clause:
7987 gnu_result = alloc_stmt_list ();
7989 /* The only one we need to deal with is 'Address since, for the others,
7990 the front-end puts the information elsewhere. */
7991 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
7992 break;
7994 /* And we only deal with 'Address if the object has a Freeze node. */
7995 gnat_temp = Entity (Name (gnat_node));
7996 if (Freeze_Node (gnat_temp))
7998 tree gnu_address = gnat_to_gnu (Expression (gnat_node)), gnu_temp;
8000 /* Get the value to use as the address and save it as the equivalent
8001 for the object; when it is frozen, gnat_to_gnu_entity will do the
8002 right thing. For a subprogram, put the naked address but build a
8003 meaningfull expression for an object in case its address is taken
8004 before the Freeze node is encountered; this can happen if the type
8005 of the object is limited and it is initialized with the result of
8006 a function call. */
8007 if (Is_Subprogram (gnat_temp))
8008 gnu_temp = gnu_address;
8009 else
8011 tree gnu_type = gnat_to_gnu_type (Etype (gnat_temp));
8012 /* Drop atomic and volatile qualifiers for the expression. */
8013 gnu_type = TYPE_MAIN_VARIANT (gnu_type);
8014 gnu_type
8015 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
8016 gnu_address = convert (gnu_type, gnu_address);
8017 gnu_temp
8018 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_address);
8021 save_gnu_tree (gnat_temp, gnu_temp, true);
8023 break;
8025 case N_Enumeration_Representation_Clause:
8026 case N_Record_Representation_Clause:
8027 case N_At_Clause:
8028 /* We do nothing with these. SEM puts the information elsewhere. */
8029 gnu_result = alloc_stmt_list ();
8030 break;
8032 case N_Code_Statement:
8033 if (!type_annotate_only)
8035 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
8036 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
8037 tree gnu_clobbers = NULL_TREE, tail;
8038 bool allows_mem, allows_reg, fake;
8039 int ninputs, noutputs, i;
8040 const char **oconstraints;
8041 const char *constraint;
8042 char *clobber;
8044 /* First retrieve the 3 operand lists built by the front-end. */
8045 Setup_Asm_Outputs (gnat_node);
8046 while (Present (gnat_temp = Asm_Output_Variable ()))
8048 tree gnu_value = gnat_to_gnu (gnat_temp);
8049 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
8050 (Asm_Output_Constraint ()));
8052 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
8053 Next_Asm_Output ();
8056 Setup_Asm_Inputs (gnat_node);
8057 while (Present (gnat_temp = Asm_Input_Value ()))
8059 tree gnu_value = gnat_to_gnu (gnat_temp);
8060 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
8061 (Asm_Input_Constraint ()));
8063 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
8064 Next_Asm_Input ();
8067 Clobber_Setup (gnat_node);
8068 while ((clobber = (char *) Clobber_Get_Next ()))
8069 gnu_clobbers
8070 = tree_cons (NULL_TREE,
8071 build_string (strlen (clobber) + 1, clobber),
8072 gnu_clobbers);
8074 /* Then perform some standard checking and processing on the
8075 operands. In particular, mark them addressable if needed. */
8076 gnu_outputs = nreverse (gnu_outputs);
8077 noutputs = list_length (gnu_outputs);
8078 gnu_inputs = nreverse (gnu_inputs);
8079 ninputs = list_length (gnu_inputs);
8080 oconstraints = XALLOCAVEC (const char *, noutputs);
8082 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
8084 tree output = TREE_VALUE (tail);
8085 constraint
8086 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
8087 oconstraints[i] = constraint;
8089 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
8090 &allows_mem, &allows_reg, &fake))
8092 /* If the operand is going to end up in memory,
8093 mark it addressable. Note that we don't test
8094 allows_mem like in the input case below; this
8095 is modeled on the C front-end. */
8096 if (!allows_reg)
8098 output = remove_conversions (output, false);
8099 if (TREE_CODE (output) == CONST_DECL
8100 && DECL_CONST_CORRESPONDING_VAR (output))
8101 output = DECL_CONST_CORRESPONDING_VAR (output);
8102 if (!gnat_mark_addressable (output))
8103 output = error_mark_node;
8106 else
8107 output = error_mark_node;
8109 TREE_VALUE (tail) = output;
8112 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
8114 tree input = TREE_VALUE (tail);
8115 constraint
8116 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
8118 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
8119 0, oconstraints,
8120 &allows_mem, &allows_reg))
8122 /* If the operand is going to end up in memory,
8123 mark it addressable. */
8124 if (!allows_reg && allows_mem)
8126 input = remove_conversions (input, false);
8127 if (TREE_CODE (input) == CONST_DECL
8128 && DECL_CONST_CORRESPONDING_VAR (input))
8129 input = DECL_CONST_CORRESPONDING_VAR (input);
8130 if (!gnat_mark_addressable (input))
8131 input = error_mark_node;
8134 else
8135 input = error_mark_node;
8137 TREE_VALUE (tail) = input;
8140 gnu_result = build5 (ASM_EXPR, void_type_node,
8141 gnu_template, gnu_outputs,
8142 gnu_inputs, gnu_clobbers, NULL_TREE);
8143 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
8145 else
8146 gnu_result = alloc_stmt_list ();
8148 break;
8150 /****************/
8151 /* Added Nodes */
8152 /****************/
8154 /* Markers are created by the ABE mechanism to capture information which
8155 is either unavailable of expensive to recompute. Markers do not have
8156 and runtime semantics, and should be ignored. */
8158 case N_Call_Marker:
8159 case N_Variable_Reference_Marker:
8160 gnu_result = alloc_stmt_list ();
8161 break;
8163 case N_Expression_With_Actions:
8164 /* This construct doesn't define a scope so we don't push a binding
8165 level around the statement list, but we wrap it in a SAVE_EXPR to
8166 protect it from unsharing. Elaborate the expression as part of the
8167 same statement group as the actions so that the type declaration
8168 gets inserted there as well. This ensures that the type elaboration
8169 code is issued past the actions computing values on which it might
8170 depend. */
8171 start_stmt_group ();
8172 add_stmt_list (Actions (gnat_node));
8173 gnu_expr = gnat_to_gnu (Expression (gnat_node));
8174 gnu_result = end_stmt_group ();
8176 gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
8177 TREE_SIDE_EFFECTS (gnu_result) = 1;
8179 gnu_result
8180 = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
8181 gnu_result_type = get_unpadded_type (Etype (gnat_node));
8182 break;
8184 case N_Freeze_Entity:
8185 start_stmt_group ();
8186 process_freeze_entity (gnat_node);
8187 process_decls (Actions (gnat_node), Empty, true, true);
8188 gnu_result = end_stmt_group ();
8189 break;
8191 case N_Freeze_Generic_Entity:
8192 gnu_result = alloc_stmt_list ();
8193 break;
8195 case N_Itype_Reference:
8196 if (!present_gnu_tree (Itype (gnat_node)))
8197 process_type (Itype (gnat_node));
8198 gnu_result = alloc_stmt_list ();
8199 break;
8201 case N_Free_Statement:
8202 gnat_temp = Expression (gnat_node);
8204 if (!type_annotate_only)
8206 const Entity_Id gnat_desig_type
8207 = Designated_Type (Underlying_Type (Etype (gnat_temp)));
8208 const Entity_Id gnat_pool = Storage_Pool (gnat_node);
8209 const bool pool_is_storage_model
8210 = Present (gnat_pool)
8211 && Has_Storage_Model_Type_Aspect (Etype (gnat_pool))
8212 && Present (Storage_Model_Copy_From (gnat_pool));
8213 tree gnu_ptr, gnu_ptr_type, gnu_obj_type, gnu_actual_obj_type;
8215 /* Make sure the designated type is complete before dereferencing,
8216 in case it is a Taft Amendment type. */
8217 (void) gnat_to_gnu_entity (gnat_desig_type, NULL_TREE, false);
8219 gnu_ptr = gnat_to_gnu (gnat_temp);
8220 gnu_ptr_type = TREE_TYPE (gnu_ptr);
8222 /* If this is a thin pointer, we must first dereference it to create
8223 a fat pointer, then go back below to a thin pointer. The reason
8224 for this is that we need to have a fat pointer someplace in order
8225 to properly compute the size. */
8226 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
8227 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
8228 build_unary_op (INDIRECT_REF, NULL_TREE,
8229 gnu_ptr));
8231 /* If this is a fat pointer, the object must have been allocated with
8232 the template in front of the array. So pass the template address,
8233 and get the total size; do it by converting to a thin pointer. */
8234 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
8235 gnu_ptr
8236 = convert (build_pointer_type
8237 (TYPE_OBJECT_RECORD_TYPE
8238 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
8239 gnu_ptr);
8241 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
8243 /* If this is a thin pointer, the object must have been allocated with
8244 the template in front of the array. So pass the template address,
8245 and get the total size. */
8246 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
8247 gnu_ptr
8248 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
8249 gnu_ptr,
8250 fold_build1 (NEGATE_EXPR, sizetype,
8251 byte_position
8252 (DECL_CHAIN
8253 TYPE_FIELDS ((gnu_obj_type)))));
8255 /* If we have a special dynamic constrained subtype on the node, use
8256 it to compute the size; otherwise, use the designated subtype. */
8257 if (Present (Actual_Designated_Subtype (gnat_node)))
8259 gnu_actual_obj_type
8260 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
8262 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
8263 gnu_actual_obj_type
8264 = build_unc_object_type_from_ptr (gnu_ptr_type,
8265 gnu_actual_obj_type,
8266 get_identifier ("DEALLOC"),
8267 false);
8269 else
8270 gnu_actual_obj_type = gnu_obj_type;
8272 tree gnu_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
8273 gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_ptr);
8274 if (pool_is_storage_model)
8275 gnu_size = INSTANTIATE_LOAD_IN_EXPR (gnu_size, gnat_pool);
8277 gnu_result
8278 = build_call_alloc_dealloc (gnu_ptr, gnu_size, gnu_obj_type,
8279 Procedure_To_Call (gnat_node),
8280 gnat_pool, gnat_node);
8282 break;
8284 case N_Raise_Constraint_Error:
8285 case N_Raise_Program_Error:
8286 case N_Raise_Storage_Error:
8287 if (type_annotate_only)
8288 gnu_result = alloc_stmt_list ();
8289 else
8290 gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type);
8291 break;
8293 case N_Validate_Unchecked_Conversion:
8294 /* The only validation we currently do on an unchecked conversion is
8295 that of aliasing assumptions. */
8296 if (flag_strict_aliasing)
8297 gnat_validate_uc_list.safe_push (gnat_node);
8298 gnu_result = alloc_stmt_list ();
8299 break;
8301 case N_Function_Specification:
8302 case N_Procedure_Specification:
8303 case N_Op_Concat:
8304 case N_Component_Association:
8305 /* These nodes should only be present when annotating types. */
8306 gcc_assert (type_annotate_only);
8307 gnu_result = alloc_stmt_list ();
8308 break;
8310 default:
8311 /* Other nodes are not supposed to reach here. */
8312 gcc_unreachable ();
8315 /* If we are in the elaboration procedure, check if we are violating the
8316 No_Elaboration_Code restriction by having a non-empty statement. */
8317 if (statement_node_p (gnat_node)
8318 && !(TREE_CODE (gnu_result) == STATEMENT_LIST
8319 && empty_stmt_list_p (gnu_result))
8320 && current_function_decl == get_elaboration_procedure ())
8321 Check_Elaboration_Code_Allowed (gnat_node);
8323 /* If we pushed the processing of the elaboration routine, pop it back. */
8324 if (went_into_elab_proc)
8325 current_function_decl = NULL_TREE;
8327 /* When not optimizing, turn boolean rvalues B into B != false tests
8328 so that we can put the location information of the reference to B on
8329 the inequality operator for better debug info. */
8330 if (!optimize
8331 && TREE_CODE (gnu_result) != INTEGER_CST
8332 && TREE_CODE (gnu_result) != TYPE_DECL
8333 && (kind == N_Identifier
8334 || kind == N_Expanded_Name
8335 || kind == N_Explicit_Dereference
8336 || kind == N_Indexed_Component
8337 || kind == N_Selected_Component)
8338 && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
8339 && Nkind (Parent (gnat_node)) != N_Attribute_Reference
8340 && Nkind (Parent (gnat_node)) != N_Pragma_Argument_Association
8341 && Nkind (Parent (gnat_node)) != N_Variant_Part
8342 && !lvalue_required_p (gnat_node, gnu_result_type, false, false))
8344 gnu_result
8345 = build_binary_op (NE_EXPR, gnu_result_type,
8346 convert (gnu_result_type, gnu_result),
8347 convert (gnu_result_type, boolean_false_node));
8348 if (TREE_CODE (gnu_result) != INTEGER_CST)
8349 set_gnu_expr_location_from_node (gnu_result, gnat_node);
8352 /* Set the location information on the result if it's not a simple name
8353 or something that contains a simple name, for example a tag, because
8354 we don"t want all the references to get the location of the first use.
8355 Note that we may have no result if we tried to build a CALL_EXPR node
8356 to a procedure with no side-effects and optimization is enabled. */
8357 else if (kind != N_Identifier
8358 && !(kind == N_Selected_Component
8359 && Chars (Selector_Name (gnat_node)) == Name_uTag)
8360 && gnu_result
8361 && EXPR_P (gnu_result))
8362 set_gnu_expr_location_from_node (gnu_result, gnat_node);
8364 /* If we're supposed to return something of void_type, it means we have
8365 something we're elaborating for effect, so just return. */
8366 if (VOID_TYPE_P (gnu_result_type))
8367 return gnu_result;
8369 /* If the result is a constant that overflowed, raise Constraint_Error. */
8370 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
8372 post_error ("??Constraint_Error will be raised at run time", gnat_node);
8373 gnu_result
8374 = build1 (NULL_EXPR, gnu_result_type,
8375 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
8376 N_Raise_Constraint_Error));
8379 /* If the result has side-effects and is of an unconstrained type, protect
8380 the expression in case it will be referenced multiple times, i.e. for
8381 its value and to compute the size of an object. But do it neither for
8382 an object nor a renaming declaration, nor a return statement of a call
8383 to a function that returns an unconstrained record type with default
8384 discriminant, because there is no size to be computed in these cases
8385 and this will create a useless temporary. We must do this before any
8386 conversions. */
8387 if (TREE_SIDE_EFFECTS (gnu_result)
8388 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
8389 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
8390 && !(TREE_CODE (gnu_result) == CALL_EXPR
8391 && type_is_padding_self_referential (TREE_TYPE (gnu_result))
8392 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
8393 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration
8394 || Nkind (Parent (gnat_node)) == N_Simple_Return_Statement)))
8395 gnu_result = gnat_protect_expr (gnu_result);
8397 /* Now convert the result to the result type, unless we are in one of the
8398 following cases:
8400 1. If this is the LHS of an assignment or an actual parameter of a
8401 call, return the result almost unmodified since the RHS will have
8402 to be converted to our type in that case, unless the result type
8403 has a simpler size or for array types because this size might be
8404 changed in-between. Likewise if there is just a no-op unchecked
8405 conversion in-between. Similarly, don't convert integral types
8406 that are the operands of an unchecked conversion since we need
8407 to ignore those conversions (for 'Valid).
8409 2. If we have a label (which doesn't have any well-defined type), a
8410 field or an error, return the result almost unmodified. Similarly,
8411 if the two types are record types with the same name, don't convert.
8412 This will be the case when we are converting from a packable version
8413 of a type to its original type and we need those conversions to be
8414 NOPs in order for assignments into these types to work properly.
8416 3. If the type is void or if we have no result, return error_mark_node
8417 to show we have no result.
8419 4. If this is a call to a function that returns with variable size and
8420 the call is used as the expression in either an object or a renaming
8421 declaration, return the result unmodified because we want to use the
8422 return slot optimization in this case.
8424 5. If this is a reference to an unconstrained array which is used either
8425 as the prefix of an attribute reference that requires an lvalue or in
8426 a return statement, then return the result unmodified because we want
8427 to return the original bounds.
8429 6. Finally, if the type of the result is already correct. */
8431 if (Present (Parent (gnat_node))
8432 && (lhs_or_actual_p (gnat_node)
8433 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
8434 && unchecked_conversion_nop (Parent (gnat_node)))
8435 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
8436 && !AGGREGATE_TYPE_P (gnu_result_type)
8437 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
8438 && !(TYPE_SIZE (gnu_result_type)
8439 && TYPE_SIZE (TREE_TYPE (gnu_result))
8440 && AGGREGATE_TYPE_P (gnu_result_type)
8441 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
8442 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
8443 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
8444 != INTEGER_CST))
8445 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
8446 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
8447 && (CONTAINS_PLACEHOLDER_P
8448 (TYPE_SIZE (TREE_TYPE (gnu_result)))))
8449 || (TREE_CODE (gnu_result_type) == ARRAY_TYPE
8450 && TREE_CODE (TREE_TYPE (gnu_result)) == ARRAY_TYPE))
8451 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
8452 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
8454 /* Remove padding only if the inner object is of self-referential
8455 size: in that case it must be an object of unconstrained type
8456 with a default discriminant and we want to avoid copying too
8457 much data. But do not remove it if it is already too small. */
8458 if (type_is_padding_self_referential (TREE_TYPE (gnu_result))
8459 && !(TREE_CODE (gnu_result) == COMPONENT_REF
8460 && DECL_BIT_FIELD (TREE_OPERAND (gnu_result, 1))
8461 && DECL_SIZE (TREE_OPERAND (gnu_result, 1))
8462 != TYPE_SIZE (TREE_TYPE (gnu_result))))
8463 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
8464 gnu_result);
8467 else if (TREE_CODE (gnu_result) == LABEL_DECL
8468 || TREE_CODE (gnu_result) == FIELD_DECL
8469 || TREE_CODE (gnu_result) == ERROR_MARK
8470 || (TYPE_NAME (gnu_result_type)
8471 == TYPE_NAME (TREE_TYPE (gnu_result))
8472 && TREE_CODE (gnu_result_type) == RECORD_TYPE
8473 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
8475 /* Remove any padding. */
8476 gnu_result = maybe_padded_object (gnu_result);
8479 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
8480 gnu_result = error_mark_node;
8482 else if (TREE_CODE (gnu_result) == CALL_EXPR
8483 && Present (Parent (gnat_node))
8484 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
8485 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration)
8486 && return_type_with_variable_size_p (TREE_TYPE (gnu_result)))
8489 else if (TREE_CODE (TREE_TYPE (gnu_result)) == UNCONSTRAINED_ARRAY_TYPE
8490 && Present (Parent (gnat_node))
8491 && ((Nkind (Parent (gnat_node)) == N_Attribute_Reference
8492 && lvalue_required_for_attribute_p (Parent (gnat_node)))
8493 || Nkind (Parent (gnat_node)) == N_Simple_Return_Statement))
8496 else if (TREE_TYPE (gnu_result) != gnu_result_type)
8497 gnu_result = convert (gnu_result_type, gnu_result);
8499 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
8500 while ((TREE_CODE (gnu_result) == NOP_EXPR
8501 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
8502 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
8503 gnu_result = TREE_OPERAND (gnu_result, 0);
8505 return gnu_result;
8508 /* Similar to gnat_to_gnu, but discard any object that might be created in
8509 the course of the translation of GNAT_NODE, which must be an "external"
8510 expression in the sense that it will be elaborated elsewhere. */
8512 tree
8513 gnat_to_gnu_external (Node_Id gnat_node)
8515 const int save_force_global = force_global;
8516 bool went_into_elab_proc;
8518 /* Force the local context and create a fake scope that we zap
8519 at the end so declarations will not be stuck either in the
8520 global varpool or in the current scope. */
8521 if (!current_function_decl)
8523 current_function_decl = get_elaboration_procedure ();
8524 went_into_elab_proc = true;
8526 else
8527 went_into_elab_proc = false;
8528 force_global = 0;
8529 gnat_pushlevel ();
8531 tree gnu_result = gnat_to_gnu (gnat_node);
8533 gnat_zaplevel ();
8534 force_global = save_force_global;
8535 if (went_into_elab_proc)
8536 current_function_decl = NULL_TREE;
8538 /* Do not import locations from external units. */
8539 if (CAN_HAVE_LOCATION_P (gnu_result))
8540 SET_EXPR_LOCATION (gnu_result, UNKNOWN_LOCATION);
8542 return gnu_result;
8545 /* Return true if the statement list STMT_LIST is empty. */
8547 static bool
8548 empty_stmt_list_p (tree stmt_list)
8550 tree_stmt_iterator tsi;
8552 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
8554 tree stmt = tsi_stmt (tsi);
8556 /* Anything else than an empty STMT_STMT counts as something. */
8557 if (TREE_CODE (stmt) != STMT_STMT || STMT_STMT_STMT (stmt))
8558 return false;
8561 return true;
8564 /* Record the current code position in GNAT_NODE. */
8566 static void
8567 record_code_position (Node_Id gnat_node)
8569 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
8571 add_stmt_with_node (stmt_stmt, gnat_node);
8572 save_gnu_tree (gnat_node, stmt_stmt, true);
8575 /* Insert the code for GNAT_NODE at the position saved for that node. */
8577 static void
8578 insert_code_for (Node_Id gnat_node)
8580 tree code = gnat_to_gnu (gnat_node);
8582 /* It's too late to remove the STMT_STMT itself at this point. */
8583 if (!empty_stmt_list_p (code))
8584 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = code;
8586 save_gnu_tree (gnat_node, NULL_TREE, true);
8589 /* Start a new statement group chained to the previous group. */
8591 void
8592 start_stmt_group (void)
8594 struct stmt_group *group = stmt_group_free_list;
8596 /* First see if we can get one from the free list. */
8597 if (group)
8598 stmt_group_free_list = group->previous;
8599 else
8600 group = ggc_alloc<stmt_group> ();
8602 group->previous = current_stmt_group;
8603 group->stmt_list = group->block = group->cleanups = NULL_TREE;
8604 current_stmt_group = group;
8607 /* Add GNU_STMT to the current statement group. If it is an expression with
8608 no effects, it is ignored. */
8610 void
8611 add_stmt (tree gnu_stmt)
8613 append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
8616 /* Similar, but the statement is always added, regardless of side-effects. */
8618 void
8619 add_stmt_force (tree gnu_stmt)
8621 append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
8624 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
8626 void
8627 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
8629 if (Present (gnat_node))
8630 set_expr_location_from_node (gnu_stmt, gnat_node);
8631 add_stmt (gnu_stmt);
8634 /* Similar, but the statement is always added, regardless of side-effects. */
8636 void
8637 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
8639 if (Present (gnat_node))
8640 set_expr_location_from_node (gnu_stmt, gnat_node);
8641 add_stmt_force (gnu_stmt);
8644 /* Add a declaration statement for GNU_DECL to the current statement group.
8645 Get the SLOC to be put onto the statement from GNAT_NODE. */
8647 void
8648 add_decl_expr (tree gnu_decl, Node_Id gnat_node)
8650 tree type = TREE_TYPE (gnu_decl);
8651 tree gnu_stmt, gnu_init;
8653 /* If this is a variable that Gigi is to ignore, we may have been given
8654 an ERROR_MARK. So test for it. We also might have been given a
8655 reference for a renaming. So only do something for a decl. Also
8656 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
8657 if (!DECL_P (gnu_decl)
8658 || (TREE_CODE (gnu_decl) == TYPE_DECL
8659 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
8660 return;
8662 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
8664 /* If we are external or global, we don't want to output the DECL_EXPR for
8665 this DECL node since we already have evaluated the expressions in the
8666 sizes and positions as globals and doing it again would be wrong. */
8667 if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ())
8669 /* Mark everything as used to prevent node sharing with subprograms.
8670 Note that walk_tree knows how to deal with TYPE_DECL, but neither
8671 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
8672 MARK_VISITED (gnu_stmt);
8673 if (VAR_P (gnu_decl)
8674 || TREE_CODE (gnu_decl) == CONST_DECL)
8676 MARK_VISITED (DECL_SIZE (gnu_decl));
8677 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
8678 MARK_VISITED (DECL_INITIAL (gnu_decl));
8681 else
8682 add_stmt_with_node (gnu_stmt, gnat_node);
8684 /* Mark our TYPE_ADA_SIZE field now since it will not be gimplified. */
8685 if (TREE_CODE (gnu_decl) == TYPE_DECL
8686 && RECORD_OR_UNION_TYPE_P (type)
8687 && !TYPE_FAT_POINTER_P (type))
8688 MARK_VISITED (TYPE_ADA_SIZE (type));
8690 if (VAR_P (gnu_decl) && (gnu_init = DECL_INITIAL (gnu_decl)))
8692 /* If this is a variable and an initializer is attached to it, it must be
8693 valid for the context. Similar to init_const in create_var_decl. */
8694 if (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
8695 || (TREE_STATIC (gnu_decl)
8696 && !initializer_constant_valid_p (gnu_init,
8697 TREE_TYPE (gnu_init))))
8699 DECL_INITIAL (gnu_decl) = NULL_TREE;
8700 if (TREE_READONLY (gnu_decl))
8702 TREE_READONLY (gnu_decl) = 0;
8703 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
8706 /* Remove any padding so the assignment is done properly. */
8707 gnu_decl = maybe_padded_object (gnu_decl);
8709 gnu_stmt
8710 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init);
8711 add_stmt_with_node (gnu_stmt, gnat_node);
8714 /* If this is the initialization of a (potentially) large aggregate, then
8715 declare the dependence on the memcpy routine. */
8716 if (AGGREGATE_TYPE_P (type)
8717 && (!TREE_CONSTANT (TYPE_SIZE (type))
8718 || compare_tree_int (TYPE_SIZE (type), 2 * BITS_PER_WORD) > 0))
8719 Check_Restriction_No_Dependence_On_System (Name_Memory_Copy,
8720 gnat_node);
8724 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
8726 static tree
8727 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
8729 tree t = *tp;
8731 if (TREE_VISITED (t))
8732 *walk_subtrees = 0;
8734 /* Don't mark a dummy type as visited because we want to mark its sizes
8735 and fields once it's filled in. */
8736 else if (!TYPE_IS_DUMMY_P (t))
8737 TREE_VISITED (t) = 1;
8739 /* The test in gimplify_type_sizes is on the main variant. */
8740 if (TYPE_P (t))
8741 TYPE_SIZES_GIMPLIFIED (TYPE_MAIN_VARIANT (t)) = 1;
8743 return NULL_TREE;
8746 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8747 sized gimplified. We use this to indicate all variable sizes and
8748 positions in global types may not be shared by any subprogram. */
8750 void
8751 mark_visited (tree t)
8753 walk_tree (&t, mark_visited_r, NULL, NULL);
8756 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8757 set its location to that of GNAT_NODE if present, but with column info
8758 cleared so that conditional branches generated as part of the cleanup
8759 code do not interfere with coverage analysis tools. */
8761 static void
8762 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
8764 if (Present (gnat_node))
8765 set_expr_location_from_node (gnu_cleanup, gnat_node, true);
8767 /* An EH_ELSE_EXPR must be by itself, and that's all we need when we
8768 use it. The assert below makes sure that is so. Should we ever
8769 need more than that, we could combine EH_ELSE_EXPRs, and copy
8770 non-EH_ELSE_EXPR stmts into both cleanup paths of an
8771 EH_ELSE_EXPR. */
8772 if (TREE_CODE (gnu_cleanup) == EH_ELSE_EXPR)
8774 gcc_assert (!current_stmt_group->cleanups);
8775 current_stmt_group->cleanups = gnu_cleanup;
8777 else
8779 gcc_assert (!current_stmt_group->cleanups
8780 || (TREE_CODE (current_stmt_group->cleanups)
8781 != EH_ELSE_EXPR));
8782 append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
8786 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8788 void
8789 set_block_for_group (tree gnu_block)
8791 gcc_assert (!current_stmt_group->block);
8792 current_stmt_group->block = gnu_block;
8795 /* Return code corresponding to the current code group. It is normally
8796 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
8797 BLOCK or cleanups were set. */
8799 tree
8800 end_stmt_group (void)
8802 struct stmt_group *group = current_stmt_group;
8803 tree gnu_retval = group->stmt_list;
8805 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
8806 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
8807 make a BIND_EXPR. Note that we nest in that because the cleanup may
8808 reference variables in the block. */
8809 if (!gnu_retval)
8810 gnu_retval = alloc_stmt_list ();
8812 if (group->cleanups)
8813 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
8814 group->cleanups);
8816 if (current_stmt_group->block)
8817 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
8818 gnu_retval, group->block);
8820 /* Remove this group from the stack and add it to the free list. */
8821 current_stmt_group = group->previous;
8822 group->previous = stmt_group_free_list;
8823 stmt_group_free_list = group;
8825 return gnu_retval;
8828 /* Return whether the current statement group may fall through. */
8830 static inline bool
8831 stmt_group_may_fallthru (void)
8833 if (current_stmt_group->stmt_list)
8834 return block_may_fallthru (current_stmt_group->stmt_list);
8835 else
8836 return true;
8839 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
8840 statements.*/
8842 static void
8843 add_stmt_list (List_Id gnat_list)
8845 Node_Id gnat_node;
8847 if (Present (gnat_list))
8848 for (gnat_node = First (gnat_list); Present (gnat_node);
8849 gnat_node = Next (gnat_node))
8850 add_stmt (gnat_to_gnu (gnat_node));
8853 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
8854 If BINDING_P is true, push and pop a binding level around the list. */
8856 static tree
8857 build_stmt_group (List_Id gnat_list, bool binding_p)
8859 start_stmt_group ();
8861 if (binding_p)
8862 gnat_pushlevel ();
8864 add_stmt_list (gnat_list);
8866 if (binding_p)
8867 gnat_poplevel ();
8869 return end_stmt_group ();
8872 /* Generate GIMPLE in place for the expression at *EXPR_P. */
8875 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
8876 gimple_seq *post_p ATTRIBUTE_UNUSED)
8878 tree expr = *expr_p;
8879 tree type = TREE_TYPE (expr);
8880 tree op;
8882 if (IS_ADA_STMT (expr))
8883 return gnat_gimplify_stmt (expr_p);
8885 switch (TREE_CODE (expr))
8887 case ADDR_EXPR:
8888 op = TREE_OPERAND (expr, 0);
8890 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
8891 is put into static memory. We know that it's going to be read-only
8892 given the semantics we have and it must be in static memory when the
8893 reference is in an elaboration procedure. */
8894 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
8896 tree addr = build_fold_addr_expr (tree_output_constant_def (op));
8897 *expr_p = fold_convert (type, addr);
8898 return GS_ALL_DONE;
8901 /* Replace atomic loads with their first argument. That's necessary
8902 because the gimplifier would create a temporary otherwise. */
8903 if (TREE_SIDE_EFFECTS (op))
8904 while (handled_component_p (op) || CONVERT_EXPR_P (op))
8906 tree inner = TREE_OPERAND (op, 0);
8907 if (TREE_CODE (inner) == CALL_EXPR && call_is_atomic_load (inner))
8909 tree t = CALL_EXPR_ARG (inner, 0);
8910 if (TREE_CODE (t) == NOP_EXPR)
8911 t = TREE_OPERAND (t, 0);
8912 if (TREE_CODE (t) == ADDR_EXPR)
8913 TREE_OPERAND (op, 0) = TREE_OPERAND (t, 0);
8914 else
8915 TREE_OPERAND (op, 0) = build_fold_indirect_ref (t);
8917 else
8918 op = inner;
8920 break;
8922 case CALL_EXPR:
8923 /* If we are passing a constant fat pointer CONSTRUCTOR, make sure it is
8924 put into static memory; this performs a restricted version of constant
8925 propagation on fat pointers in calls. But do not do it for strings to
8926 avoid blocking concatenation in the caller when it is inlined. */
8927 for (int i = 0; i < call_expr_nargs (expr); i++)
8929 tree arg = CALL_EXPR_ARG (expr, i);
8931 if (TREE_CODE (arg) == CONSTRUCTOR
8932 && TREE_CONSTANT (arg)
8933 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (arg)))
8935 tree t = CONSTRUCTOR_ELT (arg, 0)->value;
8936 if (TREE_CODE (t) == NOP_EXPR)
8937 t = TREE_OPERAND (t, 0);
8938 if (TREE_CODE (t) == ADDR_EXPR)
8939 t = TREE_OPERAND (t, 0);
8940 if (TREE_CODE (t) != STRING_CST)
8941 CALL_EXPR_ARG (expr, i) = tree_output_constant_def (arg);
8944 break;
8946 case DECL_EXPR:
8947 op = DECL_EXPR_DECL (expr);
8949 /* The expressions for the RM bounds must be gimplified to ensure that
8950 they are properly elaborated. See gimplify_decl_expr. */
8951 if ((TREE_CODE (op) == TYPE_DECL || VAR_P (op))
8952 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op))
8953 && (INTEGRAL_TYPE_P (TREE_TYPE (op))
8954 || SCALAR_FLOAT_TYPE_P (TREE_TYPE (op))))
8956 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
8958 val = TYPE_RM_MIN_VALUE (type);
8959 if (val)
8961 gimplify_one_sizepos (&val, pre_p);
8962 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8963 SET_TYPE_RM_MIN_VALUE (t, val);
8966 val = TYPE_RM_MAX_VALUE (type);
8967 if (val)
8969 gimplify_one_sizepos (&val, pre_p);
8970 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8971 SET_TYPE_RM_MAX_VALUE (t, val);
8974 break;
8976 case NULL_EXPR:
8977 /* If this is an aggregate type, build a null pointer of the appropriate
8978 type and dereference it. */
8979 if (AGGREGATE_TYPE_P (type)
8980 || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
8981 *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE,
8982 convert (build_pointer_type (type),
8983 integer_zero_node));
8985 /* Otherwise, just make a VAR_DECL. */
8986 else
8988 *expr_p = create_tmp_var (type, NULL);
8989 suppress_warning (*expr_p);
8992 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
8993 return GS_OK;
8995 case SAVE_EXPR:
8996 op = TREE_OPERAND (expr, 0);
8998 /* Propagate TREE_NO_WARNING from expression to temporary by using the
8999 SAVE_EXPR itself as an intermediate step. See gimplify_save_expr. */
9000 if (type == void_type_node)
9002 else if (SAVE_EXPR_RESOLVED_P (expr))
9003 TREE_NO_WARNING (op) = TREE_NO_WARNING (expr);
9004 else
9005 TREE_NO_WARNING (expr) = TREE_NO_WARNING (op);
9006 break;
9008 case LOAD_EXPR:
9010 tree new_var = create_tmp_var (type, "L");
9011 TREE_ADDRESSABLE (new_var) = 1;
9013 tree init = TREE_OPERAND (expr, 1);
9014 gcc_assert (TREE_CODE (init) == CALL_EXPR);
9015 tree arg = CALL_EXPR_ARG (init, 1);
9016 CALL_EXPR_ARG (init, 1)
9017 = build_unary_op (ADDR_EXPR, TREE_TYPE (arg), new_var);
9018 gimplify_and_add (init, pre_p);
9020 *expr_p = new_var;
9021 return GS_OK;
9024 case VIEW_CONVERT_EXPR:
9025 op = TREE_OPERAND (expr, 0);
9027 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
9028 type to a scalar one, explicitly create the local temporary. That's
9029 required if the type is passed by reference. */
9030 if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
9031 && AGGREGATE_TYPE_P (TREE_TYPE (op))
9032 && !AGGREGATE_TYPE_P (type))
9034 tree new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
9035 gimple_add_tmp_var (new_var);
9037 tree mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
9038 gimplify_and_add (mod, pre_p);
9040 TREE_OPERAND (expr, 0) = new_var;
9041 return GS_OK;
9043 break;
9045 case UNCONSTRAINED_ARRAY_REF:
9046 /* We should only do this if we are just elaborating for side effects,
9047 but we can't know that yet. */
9048 *expr_p = TREE_OPERAND (expr, 0);
9049 return GS_OK;
9051 default:
9052 break;
9055 return GS_UNHANDLED;
9058 /* Generate GIMPLE in place for the statement at *STMT_P. */
9060 static enum gimplify_status
9061 gnat_gimplify_stmt (tree *stmt_p)
9063 tree stmt = *stmt_p;
9065 switch (TREE_CODE (stmt))
9067 case STMT_STMT:
9068 *stmt_p = STMT_STMT_STMT (stmt);
9069 return GS_OK;
9071 case LOOP_STMT:
9073 tree gnu_start_label = create_artificial_label (input_location);
9074 tree gnu_cond = LOOP_STMT_COND (stmt);
9075 tree gnu_update = LOOP_STMT_UPDATE (stmt);
9076 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
9078 /* Build the condition expression from the test, if any. */
9079 if (gnu_cond)
9081 /* Deal with the optimization hints. */
9082 if (LOOP_STMT_IVDEP (stmt))
9083 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
9084 build_int_cst (integer_type_node,
9085 annot_expr_ivdep_kind),
9086 integer_zero_node);
9087 if (LOOP_STMT_NO_UNROLL (stmt))
9088 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
9089 build_int_cst (integer_type_node,
9090 annot_expr_unroll_kind),
9091 integer_one_node);
9092 if (LOOP_STMT_UNROLL (stmt))
9093 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
9094 build_int_cst (integer_type_node,
9095 annot_expr_unroll_kind),
9096 build_int_cst (NULL_TREE, USHRT_MAX));
9097 if (LOOP_STMT_NO_VECTOR (stmt))
9098 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
9099 build_int_cst (integer_type_node,
9100 annot_expr_no_vector_kind),
9101 integer_zero_node);
9102 if (LOOP_STMT_VECTOR (stmt))
9103 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
9104 build_int_cst (integer_type_node,
9105 annot_expr_vector_kind),
9106 integer_zero_node);
9108 gnu_cond
9109 = build3 (COND_EXPR, void_type_node, gnu_cond, NULL_TREE,
9110 build1 (GOTO_EXPR, void_type_node, gnu_end_label));
9113 /* Set to emit the statements of the loop. */
9114 *stmt_p = NULL_TREE;
9116 /* We first emit the start label and then a conditional jump to the
9117 end label if there's a top condition, then the update if it's at
9118 the top, then the body of the loop, then a conditional jump to
9119 the end label if there's a bottom condition, then the update if
9120 it's at the bottom, and finally a jump to the start label and the
9121 definition of the end label. */
9122 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
9123 gnu_start_label),
9124 stmt_p);
9126 if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
9127 append_to_statement_list (gnu_cond, stmt_p);
9129 if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
9130 append_to_statement_list (gnu_update, stmt_p);
9132 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
9134 if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
9135 append_to_statement_list (gnu_cond, stmt_p);
9137 if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
9138 append_to_statement_list (gnu_update, stmt_p);
9140 tree t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
9141 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
9142 append_to_statement_list (t, stmt_p);
9144 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
9145 gnu_end_label),
9146 stmt_p);
9147 return GS_OK;
9150 case EXIT_STMT:
9151 /* Build a statement to jump to the corresponding end label, then
9152 see if it needs to be conditional. */
9153 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
9154 if (EXIT_STMT_COND (stmt))
9155 *stmt_p = build3 (COND_EXPR, void_type_node,
9156 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
9157 return GS_OK;
9159 default:
9160 gcc_unreachable ();
9164 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
9166 This routine is exclusively called in type_annotate mode, to compute DDA
9167 information for types in withed units, for ASIS use. */
9169 static void
9170 elaborate_all_entities_for_package (Entity_Id gnat_package)
9172 Entity_Id gnat_entity;
9174 for (gnat_entity = First_Entity (gnat_package);
9175 Present (gnat_entity);
9176 gnat_entity = Next_Entity (gnat_entity))
9178 const Entity_Kind kind = Ekind (gnat_entity);
9180 /* We are interested only in entities visible from the main unit. */
9181 if (!Is_Public (gnat_entity))
9182 continue;
9184 /* Skip stuff internal to the compiler. */
9185 if (Is_Intrinsic_Subprogram (gnat_entity))
9186 continue;
9187 if (kind == E_Operator)
9188 continue;
9189 if (IN (kind, Subprogram_Kind)
9190 && (Present (Alias (gnat_entity))
9191 || Is_Intrinsic_Subprogram (gnat_entity)))
9192 continue;
9193 if (Is_Itype (gnat_entity))
9194 continue;
9196 /* Skip named numbers. */
9197 if (IN (kind, Named_Kind))
9198 continue;
9200 /* Skip generic declarations. */
9201 if (IN (kind, Generic_Unit_Kind))
9202 continue;
9204 /* Skip formal objects. */
9205 if (IN (kind, Formal_Object_Kind))
9206 continue;
9208 /* Skip package bodies. */
9209 if (kind == E_Package_Body)
9210 continue;
9212 /* Skip limited views that point back to the main unit. */
9213 if (IN (kind, Incomplete_Kind)
9214 && From_Limited_With (gnat_entity)
9215 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity)))
9216 continue;
9218 /* Skip types that aren't frozen. */
9219 if (IN (kind, Type_Kind) && !Is_Frozen (gnat_entity))
9220 continue;
9222 /* Recurse on real packages that aren't in the main unit. */
9223 if (kind == E_Package)
9225 if (No (Renamed_Entity (gnat_entity))
9226 && !In_Extended_Main_Code_Unit (gnat_entity))
9227 elaborate_all_entities_for_package (gnat_entity);
9229 else
9230 gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
9234 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
9235 Operate recursively but check that we aren't elaborating something more
9236 than once.
9238 This routine is exclusively called in type_annotate mode, to compute DDA
9239 information for types in withed units, for ASIS use. */
9241 static void
9242 elaborate_all_entities (Node_Id gnat_node)
9244 Entity_Id gnat_with_clause;
9246 /* Process each unit only once. As we trace the context of all relevant
9247 units transitively, including generic bodies, we may encounter the
9248 same generic unit repeatedly. */
9249 if (!present_gnu_tree (gnat_node))
9250 save_gnu_tree (gnat_node, integer_zero_node, true);
9252 /* Save entities in all context units. A body may have an implicit_with
9253 on its own spec, if the context includes a child unit, so don't save
9254 the spec twice. */
9255 for (gnat_with_clause = First (Context_Items (gnat_node));
9256 Present (gnat_with_clause);
9257 gnat_with_clause = Next (gnat_with_clause))
9258 if (Nkind (gnat_with_clause) == N_With_Clause
9259 && !present_gnu_tree (Library_Unit (gnat_with_clause))
9260 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
9262 Node_Id gnat_unit = Library_Unit (gnat_with_clause);
9263 Entity_Id gnat_entity = Entity (Name (gnat_with_clause));
9265 elaborate_all_entities (gnat_unit);
9267 if (Ekind (gnat_entity) == E_Package
9268 && No (Renamed_Entity (gnat_entity)))
9269 elaborate_all_entities_for_package (gnat_entity);
9271 else if (Ekind (gnat_entity) == E_Generic_Package)
9273 Node_Id gnat_body = Corresponding_Body (Unit (gnat_unit));
9275 /* Retrieve compilation unit node of generic body. */
9276 while (Present (gnat_body)
9277 && Nkind (gnat_body) != N_Compilation_Unit)
9278 gnat_body = Parent (gnat_body);
9280 /* If body is available, elaborate its context. */
9281 if (Present (gnat_body))
9282 elaborate_all_entities (gnat_body);
9286 if (Nkind (Unit (gnat_node)) == N_Package_Body)
9287 elaborate_all_entities (Library_Unit (gnat_node));
9290 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
9292 static void
9293 process_freeze_entity (Node_Id gnat_node)
9295 const Entity_Id gnat_entity = Entity (gnat_node);
9296 const Entity_Kind kind = Ekind (gnat_entity);
9297 tree gnu_old, gnu_new;
9299 /* If this is a package, generate code for the package body, if any. */
9300 if (kind == E_Package)
9302 const Node_Id gnat_decl = Parent (Declaration_Node (gnat_entity));
9303 if (Present (Corresponding_Body (gnat_decl)))
9304 insert_code_for (Parent (Corresponding_Body (gnat_decl)));
9305 return;
9308 /* Don't do anything for class-wide types as they are always transformed
9309 into their root type. */
9310 if (kind == E_Class_Wide_Type)
9311 return;
9313 /* Likewise for the entities internally used by the front-end to register
9314 primitives covering abstract interfaces, see Expand_N_Freeze_Entity. */
9315 if (Is_Subprogram (gnat_entity) && Present (Interface_Alias (gnat_entity)))
9316 return;
9318 /* Check for an old definition if this isn't an object with address clause,
9319 since the saved GCC tree is the address expression in that case. */
9320 gnu_old
9321 = present_gnu_tree (gnat_entity) && No (Address_Clause (gnat_entity))
9322 ? get_gnu_tree (gnat_entity) : NULL_TREE;
9324 /* Don't do anything for subprograms that may have been elaborated before
9325 their freeze nodes. This can happen, for example, because of an inner
9326 call in an instance body or because of previous compilation of a spec
9327 for inlining purposes. */
9328 if (gnu_old
9329 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
9330 && (kind == E_Function || kind == E_Procedure))
9331 || (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_old))
9332 && kind == E_Subprogram_Type)))
9333 return;
9335 /* If we have a non-dummy type old tree, we have nothing to do, except for
9336 aborting, since this node was never delayed as it should have been. We
9337 let this happen for concurrent types and their Corresponding_Record_Type,
9338 however, because each might legitimately be elaborated before its own
9339 freeze node, e.g. while processing the other. */
9340 if (gnu_old
9341 && !(TREE_CODE (gnu_old) == TYPE_DECL
9342 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
9344 gcc_assert (Is_Concurrent_Type (gnat_entity)
9345 || (Is_Record_Type (gnat_entity)
9346 && Is_Concurrent_Record_Type (gnat_entity)));
9347 return;
9350 /* Reset the saved tree, if any, and elaborate the object or type for real.
9351 If there is a full view, elaborate it and use the result. And, if this
9352 is the root type of a class-wide type, reuse it for the latter. */
9353 if (gnu_old)
9355 save_gnu_tree (gnat_entity, NULL_TREE, false);
9357 if (Is_Incomplete_Or_Private_Type (gnat_entity)
9358 && Present (Full_View (gnat_entity)))
9360 Entity_Id full_view = Full_View (gnat_entity);
9362 save_gnu_tree (full_view, NULL_TREE, false);
9364 if (Is_Private_Type (full_view)
9365 && Present (Underlying_Full_View (full_view)))
9367 full_view = Underlying_Full_View (full_view);
9368 save_gnu_tree (full_view, NULL_TREE, false);
9372 if (Is_Type (gnat_entity)
9373 && Present (Class_Wide_Type (gnat_entity))
9374 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
9375 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
9378 if (Is_Incomplete_Or_Private_Type (gnat_entity)
9379 && Present (Full_View (gnat_entity)))
9381 Entity_Id full_view = Full_View (gnat_entity);
9383 if (Is_Private_Type (full_view)
9384 && Present (Underlying_Full_View (full_view)))
9385 full_view = Underlying_Full_View (full_view);
9387 gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, true);
9389 /* Propagate back-annotations from full view to partial view. */
9390 if (!Known_Alignment (gnat_entity))
9391 Copy_Alignment (gnat_entity, full_view);
9393 if (!Known_Esize (gnat_entity))
9394 Copy_Esize (gnat_entity, full_view);
9396 if (!Known_RM_Size (gnat_entity))
9397 Copy_RM_Size (gnat_entity, full_view);
9399 /* The above call may have defined this entity (the simplest example
9400 of this is when we have a private enumeral type since the bounds
9401 will have the public view). */
9402 if (!present_gnu_tree (gnat_entity))
9403 save_gnu_tree (gnat_entity, gnu_new, false);
9405 else
9407 tree gnu_init
9408 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
9409 && present_gnu_tree (Declaration_Node (gnat_entity)))
9410 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
9412 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, true);
9415 if (Is_Type (gnat_entity)
9416 && Present (Class_Wide_Type (gnat_entity))
9417 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
9418 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
9420 /* If we have an old type and we've made pointers to this type, update those
9421 pointers. If this is a Taft amendment type in the main unit, we need to
9422 mark the type as used since other units referencing it don't see the full
9423 declaration and, therefore, cannot mark it as used themselves. */
9424 if (gnu_old)
9426 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
9427 TREE_TYPE (gnu_new));
9428 if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old)))
9429 update_profiles_with (TREE_TYPE (gnu_old));
9430 if (DECL_TAFT_TYPE_P (gnu_old))
9431 used_types_insert (TREE_TYPE (gnu_new));
9435 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
9436 We make two passes, one to elaborate anything other than bodies (but
9437 we declare a function if there was no spec). The second pass
9438 elaborates the bodies.
9440 We make a complete pass through both lists if PASS1P is true, then make
9441 the second pass over both lists if PASS2P is true. The lists usually
9442 correspond to the public and private parts of a package. */
9444 static void
9445 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
9446 bool pass1p, bool pass2p)
9448 List_Id gnat_decl_array[2];
9449 Node_Id gnat_decl;
9450 int i;
9452 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
9454 if (pass1p)
9455 for (i = 0; i <= 1; i++)
9456 if (Present (gnat_decl_array[i]))
9457 for (gnat_decl = First (gnat_decl_array[i]);
9458 Present (gnat_decl);
9459 gnat_decl = Next (gnat_decl))
9461 /* For package specs, we recurse inside the declarations,
9462 thus taking the two pass approach inside the boundary. */
9463 if (Nkind (gnat_decl) == N_Package_Declaration
9464 && (Nkind (Specification (gnat_decl)
9465 == N_Package_Specification)))
9466 process_decls (Visible_Declarations (Specification (gnat_decl)),
9467 Private_Declarations (Specification (gnat_decl)),
9468 true, false);
9470 /* Similarly for any declarations in the actions of a
9471 freeze node. */
9472 else if (Nkind (gnat_decl) == N_Freeze_Entity)
9474 process_freeze_entity (gnat_decl);
9475 process_decls (Actions (gnat_decl), Empty, true, false);
9478 /* Package bodies with freeze nodes get their elaboration deferred
9479 until the freeze node, but the code must be placed in the right
9480 place, so record the code position now. */
9481 else if (Nkind (gnat_decl) == N_Package_Body
9482 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
9483 record_code_position (gnat_decl);
9485 else if (Nkind (gnat_decl) == N_Package_Body_Stub
9486 && Present (Library_Unit (gnat_decl))
9487 && Present (Freeze_Node
9488 (Corresponding_Spec
9489 (Proper_Body (Unit
9490 (Library_Unit (gnat_decl)))))))
9491 record_code_position
9492 (Proper_Body (Unit (Library_Unit (gnat_decl))));
9494 /* We defer most subprogram bodies to the second pass. For bodies
9495 that act as their own specs and stubs, the entity itself must be
9496 elaborated in the first pass, because it may be used in other
9497 declarations. */
9498 else if (Nkind (gnat_decl) == N_Subprogram_Body)
9500 if (Acts_As_Spec (gnat_decl))
9502 Entity_Id gnat_subprog = Defining_Entity (gnat_decl);
9504 if (!Is_Generic_Subprogram (gnat_subprog))
9505 gnat_to_gnu_entity (gnat_subprog, NULL_TREE, true);
9509 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
9511 Entity_Id gnat_subprog
9512 = Defining_Entity (Specification (gnat_decl));
9514 if (!Is_Generic_Subprogram (gnat_subprog)
9515 && Ekind (gnat_subprog) != E_Subprogram_Body)
9516 gnat_to_gnu_entity (gnat_subprog, NULL_TREE, true);
9519 /* Concurrent stubs stand for the corresponding subprogram bodies,
9520 which are deferred like other bodies. */
9521 else if (Nkind (gnat_decl) == N_Task_Body_Stub
9522 || Nkind (gnat_decl) == N_Protected_Body_Stub)
9525 /* Renamed subprograms may not be elaborated yet at this point
9526 since renamings do not trigger freezing. Wait for the second
9527 pass to take care of them. */
9528 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
9531 else
9532 add_stmt (gnat_to_gnu (gnat_decl));
9535 /* Here we elaborate everything we deferred above except for package bodies,
9536 which are elaborated at their freeze nodes. Note that we must also
9537 go inside things (package specs and freeze nodes) the first pass did. */
9538 if (pass2p)
9539 for (i = 0; i <= 1; i++)
9540 if (Present (gnat_decl_array[i]))
9541 for (gnat_decl = First (gnat_decl_array[i]);
9542 Present (gnat_decl);
9543 gnat_decl = Next (gnat_decl))
9545 if (Nkind (gnat_decl) == N_Subprogram_Body
9546 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
9547 || Nkind (gnat_decl) == N_Task_Body_Stub
9548 || Nkind (gnat_decl) == N_Protected_Body_Stub)
9549 add_stmt (gnat_to_gnu (gnat_decl));
9551 else if (Nkind (gnat_decl) == N_Package_Declaration
9552 && (Nkind (Specification (gnat_decl)
9553 == N_Package_Specification)))
9554 process_decls (Visible_Declarations (Specification (gnat_decl)),
9555 Private_Declarations (Specification (gnat_decl)),
9556 false, true);
9558 else if (Nkind (gnat_decl) == N_Freeze_Entity)
9559 process_decls (Actions (gnat_decl), Empty, false, true);
9561 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
9562 add_stmt (gnat_to_gnu (gnat_decl));
9566 /* Make a unary operation of kind CODE using build_unary_op, but guard
9567 the operation by an overflow check. CODE can be one of NEGATE_EXPR
9568 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
9569 the operation is to be performed in that type. GNAT_NODE is the gnat
9570 node conveying the source location for which the error should be
9571 signaled. */
9573 static tree
9574 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
9575 Node_Id gnat_node)
9577 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
9579 operand = gnat_protect_expr (operand);
9581 return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
9582 operand, TYPE_MIN_VALUE (gnu_type)),
9583 build_unary_op (code, gnu_type, operand),
9584 CE_Overflow_Check_Failed, gnat_node);
9587 /* Make a binary operation of kind CODE using build_binary_op, but guard
9588 the operation by an overflow check. CODE can be one of PLUS_EXPR,
9589 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
9590 Usually the operation is to be performed in that type. GNAT_NODE is
9591 the GNAT node conveying the source location for which the error should
9592 be signaled. */
9594 static tree
9595 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
9596 tree right, Node_Id gnat_node)
9598 const unsigned int precision = TYPE_PRECISION (gnu_type);
9599 tree lhs = gnat_protect_expr (left);
9600 tree rhs = gnat_protect_expr (right);
9601 tree type_max = TYPE_MAX_VALUE (gnu_type);
9602 tree type_min = TYPE_MIN_VALUE (gnu_type);
9603 tree gnu_expr, check;
9604 int sgn;
9606 /* Assert that the precision is a power of 2. */
9607 gcc_assert ((precision & (precision - 1)) == 0);
9609 /* Prefer a constant on the RHS to simplify checks. */
9610 if (TREE_CODE (rhs) != INTEGER_CST
9611 && TREE_CODE (lhs) == INTEGER_CST
9612 && (code == PLUS_EXPR || code == MULT_EXPR))
9614 tree tmp = lhs;
9615 lhs = rhs;
9616 rhs = tmp;
9619 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
9621 /* If we can fold the expression to a constant, just return it.
9622 The caller will deal with overflow, no need to generate a check. */
9623 if (TREE_CODE (gnu_expr) == INTEGER_CST)
9624 return gnu_expr;
9626 /* If no operand is a constant, we use the generic implementation. */
9627 if (TREE_CODE (lhs) != INTEGER_CST && TREE_CODE (rhs) != INTEGER_CST)
9629 /* First convert the operands to the result type like build_binary_op.
9630 This is where the bias is made explicit for biased types. */
9631 lhs = convert (gnu_type, lhs);
9632 rhs = convert (gnu_type, rhs);
9634 /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
9635 if (code == MULT_EXPR && precision == 64 && BITS_PER_WORD < 64)
9637 tree int64 = gnat_type_for_size (64, 0);
9638 Check_Restriction_No_Dependence_On_System (Name_Arith_64, gnat_node);
9639 return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
9640 convert (int64, lhs),
9641 convert (int64, rhs)));
9644 /* Likewise for a 128-bit mult and a 64-bit target. */
9645 else if (code == MULT_EXPR && precision == 128 && BITS_PER_WORD < 128)
9647 tree int128 = gnat_type_for_size (128, 0);
9648 Check_Restriction_No_Dependence_On_System (Name_Arith_128, gnat_node);
9649 return convert (gnu_type, build_call_n_expr (mulv128_decl, 2,
9650 convert (int128, lhs),
9651 convert (int128, rhs)));
9654 enum internal_fn icode;
9656 switch (code)
9658 case PLUS_EXPR:
9659 icode = IFN_ADD_OVERFLOW;
9660 break;
9661 case MINUS_EXPR:
9662 icode = IFN_SUB_OVERFLOW;
9663 break;
9664 case MULT_EXPR:
9665 icode = IFN_MUL_OVERFLOW;
9666 break;
9667 default:
9668 gcc_unreachable ();
9671 tree gnu_ctype = build_complex_type (gnu_type);
9672 tree call
9673 = build_call_expr_internal_loc (UNKNOWN_LOCATION, icode, gnu_ctype, 2,
9674 lhs, rhs);
9675 tree tgt = save_expr (call);
9676 gnu_expr = build1 (REALPART_EXPR, gnu_type, tgt);
9677 check = fold_build2 (NE_EXPR, boolean_type_node,
9678 build1 (IMAGPART_EXPR, gnu_type, tgt),
9679 build_int_cst (gnu_type, 0));
9680 return
9681 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
9684 /* If one operand is a constant, we expose the overflow condition to enable
9685 a subsequent simplication or even elimination. */
9686 switch (code)
9688 case PLUS_EXPR:
9689 sgn = tree_int_cst_sgn (rhs);
9690 if (sgn > 0)
9691 /* When rhs > 0, overflow when lhs > type_max - rhs. */
9692 check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
9693 build_binary_op (MINUS_EXPR, gnu_type,
9694 type_max, rhs));
9695 else if (sgn < 0)
9696 /* When rhs < 0, overflow when lhs < type_min - rhs. */
9697 check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
9698 build_binary_op (MINUS_EXPR, gnu_type,
9699 type_min, rhs));
9700 else
9701 return gnu_expr;
9702 break;
9704 case MINUS_EXPR:
9705 if (TREE_CODE (lhs) == INTEGER_CST)
9707 sgn = tree_int_cst_sgn (lhs);
9708 if (sgn > 0)
9709 /* When lhs > 0, overflow when rhs < lhs - type_max. */
9710 check = build_binary_op (LT_EXPR, boolean_type_node, rhs,
9711 build_binary_op (MINUS_EXPR, gnu_type,
9712 lhs, type_max));
9713 else if (sgn < 0)
9714 /* When lhs < 0, overflow when rhs > lhs - type_min. */
9715 check = build_binary_op (GT_EXPR, boolean_type_node, rhs,
9716 build_binary_op (MINUS_EXPR, gnu_type,
9717 lhs, type_min));
9718 else
9719 return gnu_expr;
9721 else
9723 sgn = tree_int_cst_sgn (rhs);
9724 if (sgn > 0)
9725 /* When rhs > 0, overflow when lhs < type_min + rhs. */
9726 check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
9727 build_binary_op (PLUS_EXPR, gnu_type,
9728 type_min, rhs));
9729 else if (sgn < 0)
9730 /* When rhs < 0, overflow when lhs > type_max + rhs. */
9731 check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
9732 build_binary_op (PLUS_EXPR, gnu_type,
9733 type_max, rhs));
9734 else
9735 return gnu_expr;
9737 break;
9739 case MULT_EXPR:
9740 sgn = tree_int_cst_sgn (rhs);
9741 if (sgn > 0)
9743 if (integer_onep (rhs))
9744 return gnu_expr;
9746 tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
9747 tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
9749 /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
9750 check
9751 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9752 build_binary_op (LT_EXPR, boolean_type_node,
9753 lhs, lb),
9754 build_binary_op (GT_EXPR, boolean_type_node,
9755 lhs, ub));
9757 else if (sgn < 0)
9759 tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
9760 tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
9762 if (integer_minus_onep (rhs))
9763 /* When rhs == -1, overflow if lhs == type_min. */
9764 check
9765 = build_binary_op (EQ_EXPR, boolean_type_node, lhs, type_min);
9766 else
9767 /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
9768 check
9769 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9770 build_binary_op (LT_EXPR, boolean_type_node,
9771 lhs, lb),
9772 build_binary_op (GT_EXPR, boolean_type_node,
9773 lhs, ub));
9775 else
9776 return gnu_expr;
9777 break;
9779 default:
9780 gcc_unreachable ();
9783 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
9786 /* GNU_COND contains the condition corresponding to an index, overflow or
9787 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9788 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9789 REASON is the code that says why the exception is raised. GNAT_NODE is
9790 the node conveying the source location for which the error should be
9791 signaled.
9793 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9794 overwriting the setting inherited from the call statement, on the ground
9795 that the expression need not be evaluated just for the check. However
9796 that's incorrect because, in the GCC type system, its value is presumed
9797 to be valid so its comparison against the type bounds always yields true
9798 and, therefore, could be done without evaluating it; given that it can
9799 be a computation that overflows the bounds, the language may require the
9800 check to fail and thus the expression to be evaluated in this case. */
9802 static tree
9803 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
9805 tree gnu_call
9806 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
9807 return
9808 fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
9809 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
9810 SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr))
9811 ? build_real (TREE_TYPE (gnu_expr), dconst0)
9812 : build_int_cst (TREE_TYPE (gnu_expr), 0)),
9813 gnu_expr);
9816 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
9817 checks if OVERFLOW_P is true. If TRUNCATE_P is true, do a fp-to-integer
9818 conversion with truncation, otherwise round. GNAT_NODE is the GNAT node
9819 conveying the source location for which the error should be signaled. */
9821 static tree
9822 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
9823 bool truncate_p, Node_Id gnat_node)
9825 tree gnu_type = get_unpadded_type (gnat_type);
9826 tree gnu_base_type = get_base_type (gnu_type);
9827 tree gnu_in_type = TREE_TYPE (gnu_expr);
9828 tree gnu_in_base_type = get_base_type (gnu_in_type);
9829 tree gnu_result = gnu_expr;
9831 /* If we are not doing any checks, the output is an integral type and the
9832 input is not a floating-point type, just do the conversion. This is
9833 required for packed array types and is simpler in all cases anyway. */
9834 if (!overflow_p
9835 && INTEGRAL_TYPE_P (gnu_base_type)
9836 && !FLOAT_TYPE_P (gnu_in_base_type))
9837 return convert (gnu_type, gnu_expr);
9839 /* If the mode of the input base type is larger, then converting to it below
9840 may pessimize the final conversion step, for example generate a libcall
9841 instead of a simple instruction, so use a narrower type in this case. */
9842 if (TYPE_MODE (gnu_in_base_type) != TYPE_MODE (gnu_in_type)
9843 && !(TREE_CODE (gnu_in_type) == INTEGER_TYPE
9844 && TYPE_BIASED_REPRESENTATION_P (gnu_in_type)))
9845 gnu_in_base_type = gnat_type_for_mode (TYPE_MODE (gnu_in_type),
9846 TYPE_UNSIGNED (gnu_in_type));
9848 /* First convert the expression to the base type. This will never generate
9849 code, but makes the tests below simpler. But don't do this if converting
9850 from an integer type to an unconstrained array type since then we need to
9851 get the bounds from the original (unpacked) type. */
9852 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
9853 gnu_result = convert (gnu_in_base_type, gnu_result);
9855 /* If overflow checks are requested, we need to be sure the result will fit
9856 in the output base type. But don't do this if the input is integer and
9857 the output floating-point. */
9858 if (overflow_p
9859 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_base_type)))
9861 /* Ensure GNU_EXPR only gets evaluated once. */
9862 tree gnu_input = gnat_protect_expr (gnu_result);
9863 tree gnu_cond = boolean_false_node;
9864 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_base_type);
9865 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_base_type);
9866 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
9867 tree gnu_out_ub
9868 = (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9869 && TYPE_MODULAR_P (gnu_base_type))
9870 ? fold_build2 (MINUS_EXPR, gnu_base_type,
9871 TYPE_MODULUS (gnu_base_type),
9872 build_int_cst (gnu_base_type, 1))
9873 : TYPE_MAX_VALUE (gnu_base_type);
9875 /* Convert the lower bounds to signed types, so we're sure we're
9876 comparing them properly. Likewise, convert the upper bounds
9877 to unsigned types. */
9878 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9879 && TYPE_UNSIGNED (gnu_in_base_type))
9880 gnu_in_lb
9881 = convert (gnat_signed_type_for (gnu_in_base_type), gnu_in_lb);
9883 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9884 && !TYPE_UNSIGNED (gnu_in_base_type))
9885 gnu_in_ub
9886 = convert (gnat_unsigned_type_for (gnu_in_base_type), gnu_in_ub);
9888 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
9889 gnu_out_lb
9890 = convert (gnat_signed_type_for (gnu_base_type), gnu_out_lb);
9892 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
9893 gnu_out_ub
9894 = convert (gnat_unsigned_type_for (gnu_base_type), gnu_out_ub);
9896 /* Check each bound separately and only if the result bound
9897 is tighter than the bound on the input type. Note that all the
9898 types are base types, so the bounds must be constant. Also,
9899 the comparison is done in the base type of the input, which
9900 always has the proper signedness. First check for input
9901 integer (which means output integer), output float (which means
9902 both float), or mixed, in which case we always compare.
9903 Note that we have to do the comparison which would *fail* in the
9904 case of an error since if it's an FP comparison and one of the
9905 values is a NaN or Inf, the comparison will fail. */
9906 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9907 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
9908 : (FLOAT_TYPE_P (gnu_base_type)
9909 ? real_less (&TREE_REAL_CST (gnu_in_lb),
9910 &TREE_REAL_CST (gnu_out_lb))
9911 : 1))
9912 gnu_cond
9913 = invert_truthvalue
9914 (build_binary_op (GE_EXPR, boolean_type_node,
9915 gnu_input, convert (gnu_in_base_type,
9916 gnu_out_lb)));
9918 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9919 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
9920 : (FLOAT_TYPE_P (gnu_base_type)
9921 ? real_less (&TREE_REAL_CST (gnu_out_ub),
9922 &TREE_REAL_CST (gnu_in_ub))
9923 : 1))
9924 gnu_cond
9925 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
9926 invert_truthvalue
9927 (build_binary_op (LE_EXPR, boolean_type_node,
9928 gnu_input,
9929 convert (gnu_in_base_type,
9930 gnu_out_ub))));
9932 if (!integer_zerop (gnu_cond))
9933 gnu_result = emit_check (gnu_cond, gnu_input,
9934 CE_Overflow_Check_Failed, gnat_node);
9937 /* Now convert to the result base type. If this is a non-truncating
9938 float-to-integer conversion, round. */
9939 if (INTEGRAL_TYPE_P (gnu_base_type)
9940 && FLOAT_TYPE_P (gnu_in_base_type)
9941 && !truncate_p)
9943 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
9944 tree gnu_conv, gnu_zero, gnu_comp, calc_type;
9945 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
9946 const struct real_format *fmt;
9948 /* The following calculations depend on proper rounding to even
9949 of each arithmetic operation. In order to prevent excess
9950 precision from spoiling this property, use the widest hardware
9951 floating-point type if FP_ARITH_MAY_WIDEN is true. */
9952 calc_type
9953 = fp_arith_may_widen ? longest_float_type_node : gnu_in_base_type;
9955 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
9956 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
9957 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
9958 real_arithmetic (&pred_half, MINUS_EXPR, &dconsthalf,
9959 &half_minus_pred_half);
9960 gnu_pred_half = build_real (calc_type, pred_half);
9962 /* If the input is strictly negative, subtract this value
9963 and otherwise add it from the input. For 0.5, the result
9964 is exactly between 1.0 and the machine number preceding 1.0
9965 (for calc_type). Since the last bit of 1.0 is even, this 0.5
9966 will round to 1.0, while all other number with an absolute
9967 value less than 0.5 round to 0.0. For larger numbers exactly
9968 halfway between integers, rounding will always be correct as
9969 the true mathematical result will be closer to the higher
9970 integer compared to the lower one. So, this constant works
9971 for all floating-point numbers.
9973 The reason to use the same constant with subtract/add instead
9974 of a positive and negative constant is to allow the comparison
9975 to be scheduled in parallel with retrieval of the constant and
9976 conversion of the input to the calc_type (if necessary). */
9978 gnu_zero = build_real (gnu_in_base_type, dconst0);
9979 gnu_result = gnat_protect_expr (gnu_result);
9980 gnu_conv = convert (calc_type, gnu_result);
9981 gnu_comp
9982 = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
9983 gnu_add_pred_half
9984 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9985 gnu_subtract_pred_half
9986 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9987 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
9988 gnu_add_pred_half, gnu_subtract_pred_half);
9991 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9992 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
9993 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
9994 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
9995 else
9996 gnu_result = convert (gnu_base_type, gnu_result);
9998 /* If this is a conversion between an integer type larger than a word and a
9999 floating-point type, then declare the dependence on the libgcc routine. */
10000 if ((INTEGRAL_TYPE_P (gnu_in_base_type)
10001 && TYPE_PRECISION (gnu_in_base_type) > BITS_PER_WORD
10002 && FLOAT_TYPE_P (gnu_base_type))
10003 || (FLOAT_TYPE_P (gnu_in_base_type)
10004 && INTEGRAL_TYPE_P (gnu_base_type)
10005 && TYPE_PRECISION (gnu_base_type) > BITS_PER_WORD))
10006 Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node);
10008 return convert (gnu_type, gnu_result);
10011 /* Return true if GNU_EXPR can be directly addressed. This is the case
10012 unless it is an expression involving computation or if it involves a
10013 reference to a bitfield or to an object not sufficiently aligned for
10014 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
10015 be directly addressed as an object of this type.
10017 *** Notes on addressability issues in the Ada compiler ***
10019 This predicate is necessary in order to bridge the gap between Gigi
10020 and the middle-end about addressability of GENERIC trees. A tree
10021 is said to be addressable if it can be directly addressed, i.e. if
10022 its address can be taken, is a multiple of the type's alignment on
10023 strict-alignment architectures and returns the first storage unit
10024 assigned to the object represented by the tree.
10026 In the C family of languages, everything is in practice addressable
10027 at the language level, except for bit-fields. This means that these
10028 compilers will take the address of any tree that doesn't represent
10029 a bit-field reference and expect the result to be the first storage
10030 unit assigned to the object. Even in cases where this will result
10031 in unaligned accesses at run time, nothing is supposed to be done
10032 and the program is considered as erroneous instead (see PR c/18287).
10034 The implicit assumptions made in the middle-end are in keeping with
10035 the C viewpoint described above:
10036 - the address of a bit-field reference is supposed to be never
10037 taken; the compiler (generally) will stop on such a construct,
10038 - any other tree is addressable if it is formally addressable,
10039 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
10041 In Ada, the viewpoint is the opposite one: nothing is addressable
10042 at the language level unless explicitly declared so. This means
10043 that the compiler will both make sure that the trees representing
10044 references to addressable ("aliased" in Ada parlance) objects are
10045 addressable and make no real attempts at ensuring that the trees
10046 representing references to non-addressable objects are addressable.
10048 In the first case, Ada is effectively equivalent to C and handing
10049 down the direct result of applying ADDR_EXPR to these trees to the
10050 middle-end works flawlessly. In the second case, Ada cannot afford
10051 to consider the program as erroneous if the address of trees that
10052 are not addressable is requested for technical reasons, unlike C;
10053 as a consequence, the Ada compiler must arrange for either making
10054 sure that this address is not requested in the middle-end or for
10055 compensating by inserting temporaries if it is requested in Gigi.
10057 The first goal can be achieved because the middle-end should not
10058 request the address of non-addressable trees on its own; the only
10059 exception is for the invocation of low-level block operations like
10060 memcpy, for which the addressability requirements are lower since
10061 the type's alignment can be disregarded. In practice, this means
10062 that Gigi must make sure that such operations cannot be applied to
10063 non-BLKmode bit-fields.
10065 The second goal is achieved by means of the addressable_p predicate,
10066 which computes whether a temporary must be inserted by Gigi when the
10067 address of a tree is requested; if so, the address of the temporary
10068 will be used in lieu of that of the original tree and some glue code
10069 generated to connect everything together. */
10071 static bool
10072 addressable_p (tree gnu_expr, tree gnu_type)
10074 /* For an integral type, the size of the actual type of the object may not
10075 be greater than that of the expected type, otherwise an indirect access
10076 in the latter type wouldn't correctly set all the bits of the object. */
10077 if (gnu_type
10078 && INTEGRAL_TYPE_P (gnu_type)
10079 && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
10080 return false;
10082 /* The size of the actual type of the object may not be smaller than that
10083 of the expected type, otherwise an indirect access in the latter type
10084 would be larger than the object. But only record types need to be
10085 considered in practice for this case. */
10086 if (gnu_type
10087 && TREE_CODE (gnu_type) == RECORD_TYPE
10088 && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
10089 return false;
10091 switch (TREE_CODE (gnu_expr))
10093 case VAR_DECL:
10094 case PARM_DECL:
10095 case FUNCTION_DECL:
10096 case RESULT_DECL:
10097 /* All DECLs are addressable: if they are in a register, we can force
10098 them to memory. */
10099 return true;
10101 case UNCONSTRAINED_ARRAY_REF:
10102 case INDIRECT_REF:
10103 /* Taking the address of a dereference yields the original pointer. */
10104 return true;
10106 case STRING_CST:
10107 case INTEGER_CST:
10108 case REAL_CST:
10109 /* Taking the address yields a pointer to the constant pool. */
10110 return true;
10112 case CONSTRUCTOR:
10113 /* Taking the address of a static constructor yields a pointer to the
10114 tree constant pool. */
10115 return TREE_STATIC (gnu_expr) ? true : false;
10117 case NULL_EXPR:
10118 case ADDR_EXPR:
10119 case SAVE_EXPR:
10120 case CALL_EXPR:
10121 case PLUS_EXPR:
10122 case MINUS_EXPR:
10123 case BIT_IOR_EXPR:
10124 case BIT_XOR_EXPR:
10125 case BIT_AND_EXPR:
10126 case BIT_NOT_EXPR:
10127 /* All rvalues are deemed addressable since taking their address will
10128 force a temporary to be created by the middle-end. */
10129 return true;
10131 case COMPOUND_EXPR:
10132 /* The address of a compound expression is that of its 2nd operand. */
10133 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
10135 case COND_EXPR:
10136 /* We accept &COND_EXPR as soon as both operands are addressable and
10137 expect the outcome to be the address of the selected operand. */
10138 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
10139 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
10141 case COMPONENT_REF:
10142 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
10143 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
10144 the field is sufficiently aligned, in case it is subject
10145 to a pragma Component_Alignment. But we don't need to
10146 check the alignment of the containing record, as it is
10147 guaranteed to be not smaller than that of its most
10148 aligned field that is not a bit-field. */
10149 && (!STRICT_ALIGNMENT
10150 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
10151 >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
10152 /* The field of a padding record is always addressable. */
10153 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
10154 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
10156 case ARRAY_REF: case ARRAY_RANGE_REF:
10157 case REALPART_EXPR: case IMAGPART_EXPR:
10158 case NOP_EXPR:
10159 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
10161 case CONVERT_EXPR:
10162 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
10163 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
10165 case VIEW_CONVERT_EXPR:
10167 /* This is addressable if we can avoid a copy. */
10168 tree type = TREE_TYPE (gnu_expr);
10169 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
10170 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
10171 && (!STRICT_ALIGNMENT
10172 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
10173 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
10174 || ((TYPE_MODE (type) == BLKmode
10175 || TYPE_MODE (inner_type) == BLKmode)
10176 && (!STRICT_ALIGNMENT
10177 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
10178 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
10179 || TYPE_ALIGN_OK (type)
10180 || TYPE_ALIGN_OK (inner_type))))
10181 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
10184 default:
10185 return false;
10189 /* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
10190 If a Freeze node exists for the entity, delay the bulk of the processing.
10191 Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
10193 void
10194 process_type (Entity_Id gnat_entity)
10196 tree gnu_old
10197 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
10199 /* If we are to delay elaboration of this type, just do any elaboration
10200 needed for expressions within the declaration and make a dummy node
10201 for it and its Full_View (if any), in case something points to it.
10202 Do not do this if it has already been done (the only way that can
10203 happen is if the private completion is also delayed). */
10204 if (Present (Freeze_Node (gnat_entity)))
10206 elaborate_entity (gnat_entity);
10208 if (!gnu_old)
10210 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
10211 save_gnu_tree (gnat_entity, gnu_decl, false);
10212 if (Is_Incomplete_Or_Private_Type (gnat_entity)
10213 && Present (Full_View (gnat_entity)))
10215 if (Has_Completion_In_Body (gnat_entity))
10216 DECL_TAFT_TYPE_P (gnu_decl) = 1;
10217 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
10221 return;
10224 /* If we saved away a dummy type for this node, it means that this made the
10225 type that corresponds to the full type of an incomplete type. Clear that
10226 type for now and then update the type in the pointers below. But, if the
10227 saved type is not dummy, it very likely means that we have a use before
10228 declaration for the type in the tree, what we really cannot handle. */
10229 if (gnu_old)
10231 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
10232 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
10234 save_gnu_tree (gnat_entity, NULL_TREE, false);
10237 /* Now fully elaborate the type. */
10238 tree gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, true);
10239 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
10241 /* If we have an old type and we've made pointers to this type, update those
10242 pointers. If this is a Taft amendment type in the main unit, we need to
10243 mark the type as used since other units referencing it don't see the full
10244 declaration and, therefore, cannot mark it as used themselves. */
10245 if (gnu_old)
10247 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
10248 TREE_TYPE (gnu_new));
10249 if (DECL_TAFT_TYPE_P (gnu_old))
10250 used_types_insert (TREE_TYPE (gnu_new));
10253 /* If this is a record type corresponding to a task or protected type
10254 that is a completion of an incomplete type, perform a similar update
10255 on the type. ??? Including protected types here is a guess. */
10256 if (Is_Record_Type (gnat_entity)
10257 && Is_Concurrent_Record_Type (gnat_entity)
10258 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
10260 tree gnu_task_old
10261 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
10263 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
10264 NULL_TREE, false);
10265 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
10266 gnu_new, false);
10268 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
10269 TREE_TYPE (gnu_new));
10273 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
10274 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
10275 associations that are from RECORD_TYPE. If we see an internal record, make
10276 a recursive call to fill it in as well. */
10278 static tree
10279 extract_values (tree values, tree record_type)
10281 vec<constructor_elt, va_gc> *v = NULL;
10282 tree field;
10284 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
10286 tree tem, value = NULL_TREE;
10288 /* _Parent is an internal field, but may have values in the aggregate,
10289 so check for values first. */
10290 if ((tem = purpose_member (field, values)))
10292 value = TREE_VALUE (tem);
10293 TREE_ADDRESSABLE (tem) = 1;
10296 else if (DECL_INTERNAL_P (field))
10298 value = extract_values (values, TREE_TYPE (field));
10299 if (TREE_CODE (value) == CONSTRUCTOR
10300 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value)))
10301 value = NULL_TREE;
10303 else
10304 /* If we have a record subtype, the names will match, but not the
10305 actual FIELD_DECLs. */
10306 for (tem = values; tem; tem = TREE_CHAIN (tem))
10307 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
10309 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
10310 TREE_ADDRESSABLE (tem) = 1;
10313 if (!value)
10314 continue;
10316 CONSTRUCTOR_APPEND_ELT (v, field, value);
10319 return gnat_build_constructor (record_type, v);
10322 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
10323 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
10324 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
10326 static tree
10327 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
10329 tree gnu_list = NULL_TREE, gnu_result;
10331 /* We test for GNU_FIELD being empty in the case where a variant
10332 was the last thing since we don't take things off GNAT_ASSOC in
10333 that case. We check GNAT_ASSOC in case we have a variant, but it
10334 has no fields. */
10336 for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
10338 const Node_Id gnat_field = First (Choices (gnat_assoc));
10339 const Node_Id gnat_expr = Expression (gnat_assoc);
10340 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
10341 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
10343 /* The expander is supposed to put a single component selector name
10344 in every record component association. */
10345 gcc_assert (No (Next (gnat_field)));
10347 /* Ignore discriminants that have Corresponding_Discriminants in tagged
10348 types since we'll be setting those fields in the parent subtype. */
10349 if (Ekind (Entity (gnat_field)) == E_Discriminant
10350 && Present (Corresponding_Discriminant (Entity (gnat_field)))
10351 && Is_Tagged_Type (Scope (Entity (gnat_field))))
10352 continue;
10354 /* Also ignore discriminants of Unchecked_Unions. */
10355 if (Ekind (Entity (gnat_field)) == E_Discriminant
10356 && Is_Unchecked_Union (gnat_entity))
10357 continue;
10359 gigi_checking_assert (!Do_Range_Check (gnat_expr));
10361 /* Convert to the type of the field. */
10362 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
10364 /* Add the field and expression to the list. */
10365 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
10368 gnu_result = extract_values (gnu_list, gnu_type);
10370 if (flag_checking)
10372 /* Verify that every entry in GNU_LIST was used. */
10373 for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
10374 gcc_assert (TREE_ADDRESSABLE (gnu_list));
10377 return gnu_result;
10380 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
10381 the first element of an array aggregate. It may itself be an aggregate.
10382 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate. */
10384 static tree
10385 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type)
10387 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
10388 vec<constructor_elt, va_gc> *gnu_expr_vec = NULL;
10390 for (; Present (gnat_expr); gnat_expr = Next (gnat_expr))
10392 tree gnu_expr;
10394 /* If the expression is itself an array aggregate then first build the
10395 innermost constructor if it is part of our array (multi-dimensional
10396 case). */
10397 if (Nkind (gnat_expr) == N_Aggregate
10398 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
10399 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
10400 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
10401 TREE_TYPE (gnu_array_type));
10402 else
10404 /* If the expression is a conversion to an unconstrained array type,
10405 skip it to avoid spilling to memory. */
10406 if (Nkind (gnat_expr) == N_Type_Conversion
10407 && Is_Array_Type (Etype (gnat_expr))
10408 && !Is_Constrained (Etype (gnat_expr)))
10409 gnu_expr = gnat_to_gnu (Expression (gnat_expr));
10410 else
10411 gnu_expr = gnat_to_gnu (gnat_expr);
10413 gigi_checking_assert (!Do_Range_Check (gnat_expr));
10416 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
10417 convert (TREE_TYPE (gnu_array_type), gnu_expr));
10419 gnu_index = int_const_binop (PLUS_EXPR, gnu_index,
10420 convert (TREE_TYPE (gnu_index),
10421 integer_one_node));
10424 return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
10427 /* Process a N_Validate_Unchecked_Conversion node. */
10429 static void
10430 validate_unchecked_conversion (Node_Id gnat_node)
10432 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
10433 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
10435 /* If the target is a pointer type, see if we are either converting from a
10436 non-pointer or from a pointer to a type with a different alias set and
10437 warn if so, unless the pointer has been marked to alias everything. */
10438 if (POINTER_TYPE_P (gnu_target_type)
10439 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
10441 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
10442 ? TREE_TYPE (gnu_source_type)
10443 : NULL_TREE;
10444 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
10445 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
10447 if (target_alias_set != 0
10448 && (!POINTER_TYPE_P (gnu_source_type)
10449 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
10450 target_alias_set)))
10452 post_error_ne ("??possible aliasing problem for type&",
10453 gnat_node, Target_Type (gnat_node));
10454 post_error ("\\?use -fno-strict-aliasing switch for references",
10455 gnat_node);
10456 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
10457 gnat_node, Target_Type (gnat_node));
10461 /* Likewise if the target is a fat pointer type, but we have no mechanism to
10462 mitigate the problem in this case, so we unconditionally warn. */
10463 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
10465 tree gnu_source_desig_type
10466 = TYPE_IS_FAT_POINTER_P (gnu_source_type)
10467 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
10468 : NULL_TREE;
10469 tree gnu_target_desig_type
10470 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
10471 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
10473 if (target_alias_set != 0
10474 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
10475 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
10476 target_alias_set)))
10478 post_error_ne ("??possible aliasing problem for type&",
10479 gnat_node, Target_Type (gnat_node));
10480 post_error ("\\?use -fno-strict-aliasing switch for references",
10481 gnat_node);
10486 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
10487 source code location and false if it doesn't. If CLEAR_COLUMN is
10488 true, set the column information to 0. If DECL is given and SLOC
10489 refers to a File with an instance, map DECL to that instance. */
10491 bool
10492 Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column,
10493 const_tree decl)
10495 if (Sloc == No_Location)
10496 return false;
10498 if (Sloc <= Standard_Location)
10500 *locus = BUILTINS_LOCATION;
10501 return false;
10504 Source_File_Index file = Get_Source_File_Index (Sloc);
10505 Line_Number_Type line = Get_Logical_Line_Number (Sloc);
10506 Column_Number_Type column = (clear_column ? 0 : Get_Column_Number (Sloc));
10507 line_map_ordinary *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
10509 /* We can have zero if pragma Source_Reference is in effect. */
10510 if (line < 1)
10511 line = 1;
10513 /* Translate the location. */
10514 *locus
10515 = linemap_position_for_line_and_column (line_table, map, line, column);
10517 if (decl && file_map && file_map[file - 1].Instance)
10518 decl_to_instance_map->put (decl, file_map[file - 1].Instance);
10520 return true;
10523 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
10524 from the parameter association for the instantiation of a generic. We do
10525 not want to emit source location for them: the code generated for their
10526 initialization is likely to disturb debugging. */
10528 bool
10529 renaming_from_instantiation_p (Node_Id gnat_node)
10531 if (Nkind (gnat_node) != N_Defining_Identifier
10532 || !Is_Object (gnat_node)
10533 || Comes_From_Source (gnat_node)
10534 || !Present (Renamed_Object (gnat_node)))
10535 return false;
10537 /* Get the object declaration of the renamed object, if any and if the
10538 renamed object is a mere identifier. */
10539 gnat_node = Renamed_Object (gnat_node);
10540 if (Nkind (gnat_node) != N_Identifier)
10541 return false;
10543 gnat_node = Parent (Entity (gnat_node));
10544 return (Present (gnat_node)
10545 && Nkind (gnat_node) == N_Object_Declaration
10546 && Present (Corresponding_Generic_Association (gnat_node)));
10549 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
10550 don't do anything if it doesn't correspond to a source location. And,
10551 if CLEAR_COLUMN is true, set the column information to 0. */
10553 static void
10554 set_expr_location_from_node (tree node, Node_Id gnat_node, bool clear_column)
10556 location_t locus;
10558 /* Do not set a location for constructs likely to disturb debugging. */
10559 if (Nkind (gnat_node) == N_Defining_Identifier)
10561 if (Is_Type (gnat_node) && Is_Actual_Subtype (gnat_node))
10562 return;
10564 if (renaming_from_instantiation_p (gnat_node))
10565 return;
10568 if (!Sloc_to_locus (Sloc (gnat_node), &locus, clear_column))
10569 return;
10571 SET_EXPR_LOCATION (node, locus);
10574 /* More elaborate version of set_expr_location_from_node to be used in more
10575 general contexts, for example the result of the translation of a generic
10576 GNAT node. */
10578 static void
10579 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
10581 /* Set the location information on the node if it is a real expression.
10582 References can be reused for multiple GNAT nodes and they would get
10583 the location information of their last use. Also make sure not to
10584 overwrite an existing location as it is probably more precise. */
10586 switch (TREE_CODE (node))
10588 CASE_CONVERT:
10589 case NON_LVALUE_EXPR:
10590 case SAVE_EXPR:
10591 break;
10593 case COMPOUND_EXPR:
10594 if (EXPR_P (TREE_OPERAND (node, 1)))
10595 set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
10597 /* ... fall through ... */
10599 default:
10600 if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
10602 set_expr_location_from_node (node, gnat_node);
10603 set_end_locus_from_node (node, gnat_node);
10605 break;
10609 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
10610 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
10611 most sense. Return true if a sensible assignment was performed. */
10613 static bool
10614 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
10616 Node_Id gnat_end_label;
10617 location_t end_locus;
10619 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
10620 end_locus when there is one. We consider only GNAT nodes with a possible
10621 End_Label attached. If the End_Label actually was unassigned, fallback
10622 on the original node. We'd better assign an explicit sloc associated with
10623 the outer construct in any case. */
10625 switch (Nkind (gnat_node))
10627 case N_Package_Body:
10628 case N_Subprogram_Body:
10629 case N_Block_Statement:
10630 if (Present (Handled_Statement_Sequence (gnat_node)))
10631 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
10632 else
10633 gnat_end_label = Empty;
10634 break;
10636 case N_Package_Declaration:
10637 gcc_checking_assert (Present (Specification (gnat_node)));
10638 gnat_end_label = End_Label (Specification (gnat_node));
10639 break;
10641 default:
10642 return false;
10645 if (Present (gnat_end_label))
10646 gnat_node = gnat_end_label;
10648 /* Some expanded subprograms have neither an End_Label nor a Sloc
10649 attached. Notify that to callers. For a block statement with no
10650 End_Label, clear column information, so that the tree for a
10651 transient block does not receive the sloc of a source condition. */
10652 if (!Sloc_to_locus (Sloc (gnat_node), &end_locus,
10653 No (gnat_end_label)
10654 && Nkind (gnat_node) == N_Block_Statement))
10655 return false;
10657 switch (TREE_CODE (gnu_node))
10659 case BIND_EXPR:
10660 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
10661 return true;
10663 case FUNCTION_DECL:
10664 DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
10665 return true;
10667 default:
10668 return false;
10672 /* Post an error message. MSG is the error message, properly annotated.
10673 NODE is the node at which to post the error and the node to use for the
10674 '&' substitution. */
10676 void
10677 post_error (const char *msg, Node_Id node)
10679 String_Template temp;
10680 String_Pointer sp;
10682 if (No (node))
10683 return;
10685 temp.Low_Bound = 1;
10686 temp.High_Bound = strlen (msg);
10687 sp.Bounds = &temp;
10688 sp.Array = msg;
10689 Error_Msg_N (sp, node);
10692 /* Similar to post_error, but NODE is the node at which to post the error and
10693 ENT is the node to use for the '&' substitution. */
10695 void
10696 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
10698 String_Template temp;
10699 String_Pointer sp;
10701 if (No (node))
10702 return;
10704 temp.Low_Bound = 1;
10705 temp.High_Bound = strlen (msg);
10706 sp.Bounds = &temp;
10707 sp.Array = msg;
10708 Error_Msg_NE (sp, node, ent);
10711 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
10713 void
10714 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
10716 Error_Msg_Uint_1 = UI_From_Int (num);
10717 post_error_ne (msg, node, ent);
10720 /* Similar to post_error_ne, but T is a GCC tree representing the number to
10721 write. If T represents a constant, the text inside curly brackets in
10722 MSG will be output (presumably including a '^'). Otherwise it will not
10723 be output and the text inside square brackets will be output instead. */
10725 void
10726 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
10728 char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
10729 char start_yes, end_yes, start_no, end_no;
10730 const char *p;
10731 char *q;
10733 if (TREE_CODE (t) == INTEGER_CST)
10735 Error_Msg_Uint_1 = UI_From_gnu (t);
10736 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
10738 else
10739 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
10741 for (p = msg, q = new_msg; *p; p++)
10743 if (*p == start_yes)
10744 for (p++; *p != end_yes; p++)
10745 *q++ = *p;
10746 else if (*p == start_no)
10747 for (p++; *p != end_no; p++)
10749 else
10750 *q++ = *p;
10753 *q = 0;
10755 post_error_ne (new_msg, node, ent);
10758 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
10760 void
10761 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
10762 int num)
10764 Error_Msg_Uint_2 = UI_From_Int (num);
10765 post_error_ne_tree (msg, node, ent, t);
10768 /* Return a label to branch to for the exception type in KIND or Empty
10769 if none. */
10771 Entity_Id
10772 get_exception_label (char kind)
10774 switch (kind)
10776 case N_Raise_Constraint_Error:
10777 return gnu_constraint_error_label_stack.last ();
10779 case N_Raise_Storage_Error:
10780 return gnu_storage_error_label_stack.last ();
10782 case N_Raise_Program_Error:
10783 return gnu_program_error_label_stack.last ();
10785 default:
10786 return Empty;
10789 gcc_unreachable ();
10792 /* Return the decl for the current elaboration procedure. */
10794 static tree
10795 get_elaboration_procedure (void)
10797 return gnu_elab_proc_stack->last ();
10800 /* Return the controlling type of a dispatching subprogram. */
10802 static Entity_Id
10803 get_controlling_type (Entity_Id subprog)
10805 /* This is modeled on Expand_Interface_Thunk. */
10806 Entity_Id controlling_type = Etype (First_Formal (subprog));
10807 if (Is_Access_Type (controlling_type))
10808 controlling_type = Directly_Designated_Type (controlling_type);
10809 controlling_type = Underlying_Type (controlling_type);
10810 if (Is_Concurrent_Type (controlling_type))
10811 controlling_type = Corresponding_Record_Type (controlling_type);
10812 controlling_type = Base_Type (controlling_type);
10813 return controlling_type;
10816 /* Return whether we should use an alias for the TARGET of a thunk
10817 in order to make the call generated in the thunk local. */
10819 static bool
10820 use_alias_for_thunk_p (tree target)
10822 /* We cannot generate a local call in this case. */
10823 if (DECL_EXTERNAL (target))
10824 return false;
10826 /* The call is already local in this case. */
10827 if (TREE_CODE (DECL_CONTEXT (target)) == FUNCTION_DECL)
10828 return false;
10830 return TARGET_USE_LOCAL_THUNK_ALIAS_P (target);
10833 static GTY(()) unsigned long thunk_labelno = 0;
10835 /* Create an alias for TARGET to be used as the target of a thunk. */
10837 static tree
10838 make_alias_for_thunk (tree target)
10840 char buf[64];
10841 targetm.asm_out.generate_internal_label (buf, "LTHUNK", thunk_labelno++);
10843 tree alias = build_decl (DECL_SOURCE_LOCATION (target), TREE_CODE (target),
10844 get_identifier (buf), TREE_TYPE (target));
10846 DECL_LANG_SPECIFIC (alias) = DECL_LANG_SPECIFIC (target);
10847 DECL_CONTEXT (alias) = DECL_CONTEXT (target);
10848 TREE_READONLY (alias) = TREE_READONLY (target);
10849 TREE_THIS_VOLATILE (alias) = TREE_THIS_VOLATILE (target);
10850 DECL_ARTIFICIAL (alias) = 1;
10851 DECL_INITIAL (alias) = error_mark_node;
10852 DECL_ARGUMENTS (alias) = copy_list (DECL_ARGUMENTS (target));
10853 TREE_ADDRESSABLE (alias) = 1;
10854 SET_DECL_ASSEMBLER_NAME (alias, DECL_NAME (alias));
10856 cgraph_node *n = cgraph_node::create_same_body_alias (alias, target);
10857 gcc_assert (n);
10859 return alias;
10862 /* Create the local covariant part of {GNAT,GNU}_THUNK. */
10864 static tree
10865 make_covariant_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
10867 tree gnu_name = create_concat_name (gnat_thunk, "CV");
10868 tree gnu_cv_thunk
10869 = build_decl (DECL_SOURCE_LOCATION (gnu_thunk), TREE_CODE (gnu_thunk),
10870 gnu_name, TREE_TYPE (gnu_thunk));
10872 DECL_ARGUMENTS (gnu_cv_thunk) = copy_list (DECL_ARGUMENTS (gnu_thunk));
10873 for (tree param_decl = DECL_ARGUMENTS (gnu_cv_thunk);
10874 param_decl;
10875 param_decl = DECL_CHAIN (param_decl))
10876 DECL_CONTEXT (param_decl) = gnu_cv_thunk;
10878 DECL_RESULT (gnu_cv_thunk) = copy_node (DECL_RESULT (gnu_thunk));
10879 DECL_CONTEXT (DECL_RESULT (gnu_cv_thunk)) = gnu_cv_thunk;
10881 DECL_LANG_SPECIFIC (gnu_cv_thunk) = DECL_LANG_SPECIFIC (gnu_thunk);
10882 DECL_CONTEXT (gnu_cv_thunk) = DECL_CONTEXT (gnu_thunk);
10883 TREE_READONLY (gnu_cv_thunk) = TREE_READONLY (gnu_thunk);
10884 TREE_THIS_VOLATILE (gnu_cv_thunk) = TREE_THIS_VOLATILE (gnu_thunk);
10885 DECL_ARTIFICIAL (gnu_cv_thunk) = 1;
10887 return gnu_cv_thunk;
10890 /* Try to create a GNU thunk for {GNAT,GNU}_THUNK and return true on success.
10892 GNU thunks are more efficient than GNAT thunks because they don't call into
10893 the runtime to retrieve the offset used in the displacement operation, but
10894 they are tailored to C++ and thus too limited to support the full range of
10895 thunks generated in Ada. Here's the complete list of limitations:
10897 1. Multi-controlling thunks, i.e thunks with more than one controlling
10898 parameter, are simply not supported.
10900 2. Covariant thunks, i.e. thunks for which the result is also controlling,
10901 are split into a pair of (this, covariant-only) thunks.
10903 3. Variable-offset thunks, i.e. thunks for which the offset depends on the
10904 object and not only on its type, are supported as 2nd class citizens.
10906 4. External thunks, i.e. thunks for which the target is not declared in
10907 the same unit as the thunk, are supported as 2nd class citizens.
10909 5. Local thunks, i.e. thunks generated for a local type, are supported as
10910 2nd class citizens. */
10912 static bool
10913 maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
10915 /* We use the Thunk_Target to compute the properties of the thunk. */
10916 const Entity_Id gnat_target = Thunk_Target (gnat_thunk);
10918 /* Check that the first formal of the target is the only controlling one. */
10919 Entity_Id gnat_formal = First_Formal (gnat_target);
10920 if (!Is_Controlling_Formal (gnat_formal))
10921 return false;
10922 for (gnat_formal = Next_Formal (gnat_formal);
10923 Present (gnat_formal);
10924 gnat_formal = Next_Formal (gnat_formal))
10925 if (Is_Controlling_Formal (gnat_formal))
10926 return false;
10928 /* Look for the types that control the target and the thunk. */
10929 const Entity_Id gnat_controlling_type = get_controlling_type (gnat_target);
10930 const Entity_Id gnat_interface_type = get_controlling_type (gnat_thunk);
10932 /* We must have an interface type at this point. */
10933 gcc_assert (Is_Interface (gnat_interface_type));
10935 /* Now compute whether the former covers the latter. */
10936 const Entity_Id gnat_interface_tag
10937 = Find_Interface_Tag (gnat_controlling_type, gnat_interface_type);
10938 tree gnu_interface_tag
10939 = Present (gnat_interface_tag)
10940 ? gnat_to_gnu_field_decl (gnat_interface_tag)
10941 : NULL_TREE;
10942 tree gnu_interface_offset
10943 = gnu_interface_tag ? byte_position (gnu_interface_tag) : NULL_TREE;
10945 /* There are three ways to retrieve the offset between the interface view
10946 and the base object. Either the controlling type covers the interface
10947 type and the offset of the corresponding tag is fixed, in which case it
10948 can be statically encoded in the thunk (see FIXED_OFFSET below). Or the
10949 controlling type doesn't cover the interface type but is of fixed size,
10950 in which case the offset is stored in the dispatch table, two pointers
10951 above the dispatch table address (see VIRTUAL_VALUE below). Otherwise,
10952 the offset is variable and is stored right after the tag in every object
10953 (see INDIRECT_OFFSET below). See also a-tags.ads for more details. */
10954 HOST_WIDE_INT fixed_offset, virtual_value, indirect_offset;
10955 tree virtual_offset;
10957 if (gnu_interface_offset && TREE_CODE (gnu_interface_offset) == INTEGER_CST)
10959 fixed_offset = - tree_to_shwi (gnu_interface_offset);
10960 virtual_value = 0;
10961 virtual_offset = NULL_TREE;
10962 indirect_offset = 0;
10964 else if (!gnu_interface_offset
10965 && !Is_Variable_Size_Record (gnat_controlling_type))
10967 fixed_offset = 0;
10968 virtual_value = - 2 * (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
10969 virtual_offset = build_int_cst (integer_type_node, virtual_value);
10970 indirect_offset = 0;
10972 else
10974 /* Covariant thunks with variable offset are not supported. */
10975 if (Has_Controlling_Result (gnat_target))
10976 return false;
10978 fixed_offset = 0;
10979 virtual_value = 0;
10980 virtual_offset = NULL_TREE;
10981 indirect_offset = (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
10984 /* But we generate a call to the Thunk_Entity in the thunk. */
10985 tree gnu_target
10986 = gnat_to_gnu_entity (Thunk_Entity (gnat_thunk), NULL_TREE, false);
10988 /* If the target is local, then thunk and target must have the same context
10989 because cgraph_node::expand_thunk can only forward the static chain. */
10990 if (DECL_STATIC_CHAIN (gnu_target)
10991 && DECL_CONTEXT (gnu_thunk) != DECL_CONTEXT (gnu_target))
10992 return false;
10994 /* If the target returns by invisible reference and is external, apply the
10995 same transformation as Subprogram_Body_to_gnu here. */
10996 if (TREE_ADDRESSABLE (TREE_TYPE (gnu_target))
10997 && DECL_EXTERNAL (gnu_target)
10998 && !POINTER_TYPE_P (TREE_TYPE (DECL_RESULT (gnu_target))))
11000 TREE_TYPE (DECL_RESULT (gnu_target))
11001 = build_reference_type (TREE_TYPE (DECL_RESULT (gnu_target)));
11002 relayout_decl (DECL_RESULT (gnu_target));
11005 /* The thunk expander requires the return types of thunk and target to be
11006 compatible, which is not fully the case with the CICO mechanism. */
11007 if (TYPE_CI_CO_LIST (TREE_TYPE (gnu_thunk)))
11009 tree gnu_target_type = TREE_TYPE (gnu_target);
11010 gcc_assert (TYPE_CI_CO_LIST (gnu_target_type));
11011 TYPE_CANONICAL (TREE_TYPE (TREE_TYPE (gnu_thunk)))
11012 = TYPE_CANONICAL (TREE_TYPE (gnu_target_type));
11015 cgraph_node *target_node = cgraph_node::get_create (gnu_target);
11017 /* We may also need to create an alias for the target in order to make
11018 the call local, depending on the linkage of the target. */
11019 tree gnu_alias = use_alias_for_thunk_p (gnu_target)
11020 ? make_alias_for_thunk (gnu_target)
11021 : gnu_target;
11023 /* If the return type of the target is a controlling type, then we need
11024 both an usual this thunk and a covariant thunk in this order:
11026 this thunk --> covariant thunk --> target
11028 For covariant thunks, we can only handle a fixed offset. */
11029 if (Has_Controlling_Result (gnat_target))
11031 gcc_assert (fixed_offset < 0);
11032 tree gnu_cv_thunk = make_covariant_thunk (gnat_thunk, gnu_thunk);
11033 target_node->create_thunk (gnu_cv_thunk, gnu_target, false,
11034 - fixed_offset, 0, 0,
11035 NULL_TREE, gnu_alias);
11037 gnu_alias = gnu_target = gnu_cv_thunk;
11040 target_node->create_thunk (gnu_thunk, gnu_target, true,
11041 fixed_offset, virtual_value, indirect_offset,
11042 virtual_offset, gnu_alias);
11044 return true;
11047 /* Initialize the table that maps GNAT codes to GCC codes for simple
11048 binary and unary operations. */
11050 static void
11051 init_code_table (void)
11053 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
11054 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
11055 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
11056 gnu_codes[N_Op_Eq] = EQ_EXPR;
11057 gnu_codes[N_Op_Ne] = NE_EXPR;
11058 gnu_codes[N_Op_Lt] = LT_EXPR;
11059 gnu_codes[N_Op_Le] = LE_EXPR;
11060 gnu_codes[N_Op_Gt] = GT_EXPR;
11061 gnu_codes[N_Op_Ge] = GE_EXPR;
11062 gnu_codes[N_Op_Add] = PLUS_EXPR;
11063 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
11064 gnu_codes[N_Op_Multiply] = MULT_EXPR;
11065 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
11066 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
11067 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
11068 gnu_codes[N_Op_Abs] = ABS_EXPR;
11069 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
11070 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
11071 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
11072 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
11073 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
11074 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
11075 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
11076 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
11079 #include "gt-ada-trans.h"