1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
20 * *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
23 * *
24 ****************************************************************************/
25
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "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"
54
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"
71
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
76
77 /* Pointers to front-end tables accessed through macros. */
78 struct Node *Nodes_Ptr;
79 struct Flags *Flags_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;
87
88 /* Highest number in the front-end node table. */
89 int max_gnat_nodes;
90
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;
95
96 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
97 static vec<Node_Id> gnat_validate_uc_list;
98
99 /* List of expressions of pragma Compile_Time_{Error|Warning} in the unit. */
100 static vec<Node_Id> gnat_compile_time_expr_list;
101
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;
111 };
112
113 typedef struct parm_attr_d *parm_attr;
114
115
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;
121 };
122
123 #define f_parm_attr_cache \
124 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
125
126 #define f_named_ret_val \
127 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
128
129 #define f_other_ret_val \
130 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
131
132 #define f_gnat_ret \
133 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
134
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. */
139
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. */
145 };
146
147 static GTY(()) struct stmt_group *current_stmt_group;
148
149 /* List of unused struct stmt_group nodes. */
150 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
151
152 /* A structure used to record information on elaboration procedures
153 we've made and need to process.
154
155 ??? gnat_node should be Node_Id, but gengtype gets confused. */
156
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. */
161 };
162
163 static GTY(()) struct elab_info *elab_info_list;
164
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;
169
170 /* In ZCX case, current exception pointer. Used to re-raise it. */
171 static GTY(()) tree gnu_incoming_exc_ptr;
172
173 /* Stack for storing the current elaboration procedure decl. */
174 static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack;
175
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;
179
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;
183
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;
193 };
194
195 typedef struct range_check_info_d *range_check_info;
196
197
198 /* Structure used to record information for a loop. */
199 struct GTY(()) loop_info_d {
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 };
209
210 typedef struct loop_info_d *loop_info;
211
212
213 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
214 static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
215
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;
220
221 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
222 static enum tree_code gnu_codes[Number_Node_Kinds];
223
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, Node_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);
253
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. */
257
258 static struct File_Info_Type *file_map;
259
260 /* Return the string of the identifier allocated for the file name Id. */
261
262 static const char*
File_Name_to_gnu(Name_Id Id)263 File_Name_to_gnu (Name_Id Id)
264 {
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));
268
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));
273 }
274
275 /* This is the main program of the back-end. It sets up all the table
276 structures and then generates code. */
277
278 void
gigi(Node_Id gnat_root,int max_gnat_node,int number_name ATTRIBUTE_UNUSED,struct Node * nodes_ptr,struct Flags * flags_ptr,Node_Id * next_node_ptr,Node_Id * prev_node_ptr,struct Elist_Header * elists_ptr,struct Elmt_Item * elmts_ptr,struct String_Entry * strings_ptr,Char_Code * string_chars_ptr,struct List_Header * list_headers_ptr,Nat number_file,struct File_Info_Type * file_info_ptr,Entity_Id standard_boolean,Entity_Id standard_integer,Entity_Id standard_character,Entity_Id standard_long_long_float,Entity_Id standard_exception_type,Int gigi_operating_mode)279 gigi (Node_Id gnat_root,
280 int max_gnat_node,
281 int number_name ATTRIBUTE_UNUSED,
282 struct Node *nodes_ptr,
283 struct Flags *flags_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_boolean,
294 Entity_Id standard_integer,
295 Entity_Id standard_character,
296 Entity_Id standard_long_long_float,
297 Entity_Id standard_exception_type,
298 Int gigi_operating_mode)
299 {
300 Node_Id gnat_iter;
301 Entity_Id gnat_literal;
302 tree t, ftype, int64_type;
303 struct elab_info *info;
304 int i;
305
306 max_gnat_nodes = max_gnat_node;
307
308 Nodes_Ptr = nodes_ptr;
309 Flags_Ptr = flags_ptr;
310 Next_Node_Ptr = next_node_ptr;
311 Prev_Node_Ptr = prev_node_ptr;
312 Elists_Ptr = elists_ptr;
313 Elmts_Ptr = elmts_ptr;
314 Strings_Ptr = strings_ptr;
315 String_Chars_Ptr = string_chars_ptr;
316 List_Headers_Ptr = list_headers_ptr;
317
318 type_annotate_only = (gigi_operating_mode == 1);
319
320 if (Generate_SCO_Instance_Table != 0)
321 {
322 file_map = file_info_ptr;
323 maybe_create_decl_to_instance_map (number_file);
324 }
325
326 for (i = 0; i < number_file; i++)
327 {
328 /* We rely on the order isomorphism between files and line maps. */
329 if ((int) LINEMAPS_ORDINARY_USED (line_table) != i)
330 {
331 gcc_assert (i > 0);
332 error ("%s contains too many lines",
333 File_Name_to_gnu (file_info_ptr[i - 1].File_Name));
334 }
335
336 /* We create the line map for a source file at once, with a fixed number
337 of columns chosen to avoid jumping over the next power of 2. */
338 linemap_add (line_table, LC_ENTER, 0,
339 File_Name_to_gnu (file_info_ptr[i].File_Name), 1);
340 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
341 linemap_position_for_column (line_table, 252 - 1);
342 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
343 }
344
345 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
346
347 /* Declare the name of the compilation unit as the first global
348 name in order to make the middle-end fully deterministic. */
349 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
350 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
351
352 /* Initialize ourselves. */
353 init_code_table ();
354 init_gnat_decl ();
355 init_gnat_utils ();
356
357 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
358 errors. */
359 if (type_annotate_only)
360 {
361 TYPE_SIZE (void_type_node) = bitsize_zero_node;
362 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
363 }
364
365 /* Enable GNAT stack checking method if needed */
366 if (!Stack_Check_Probes_On_Target)
367 set_stack_check_libfunc ("_gnat_stack_check");
368
369 /* Retrieve alignment settings. */
370 double_float_alignment = get_target_double_float_alignment ();
371 double_scalar_alignment = get_target_double_scalar_alignment ();
372
373 /* Record the builtin types. Define `integer' and `character' first so that
374 dbx will output them first. */
375 record_builtin_type ("integer", integer_type_node, false);
376 record_builtin_type ("character", char_type_node, false);
377 record_builtin_type ("boolean", boolean_type_node, false);
378 record_builtin_type ("void", void_type_node, false);
379
380 /* Save the type we made for integer as the type for Standard.Integer. */
381 save_gnu_tree (Base_Type (standard_integer),
382 TYPE_NAME (integer_type_node),
383 false);
384
385 /* Likewise for character as the type for Standard.Character. */
386 finish_character_type (char_type_node);
387 save_gnu_tree (Base_Type (standard_character),
388 TYPE_NAME (char_type_node),
389 false);
390
391 /* Likewise for boolean as the type for Standard.Boolean. */
392 save_gnu_tree (Base_Type (standard_boolean),
393 TYPE_NAME (boolean_type_node),
394 false);
395 gnat_literal = First_Literal (Base_Type (standard_boolean));
396 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
397 gcc_assert (t == boolean_false_node);
398 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
399 boolean_type_node, t, true, false, false, false, false,
400 true, false, NULL, gnat_literal);
401 save_gnu_tree (gnat_literal, t, false);
402 gnat_literal = Next_Literal (gnat_literal);
403 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
404 gcc_assert (t == boolean_true_node);
405 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
406 boolean_type_node, t, true, false, false, false, false,
407 true, false, NULL, gnat_literal);
408 save_gnu_tree (gnat_literal, t, false);
409
410 /* Declare the building blocks of function nodes. */
411 void_list_node = build_tree_list (NULL_TREE, void_type_node);
412 void_ftype = build_function_type_list (void_type_node, NULL_TREE);
413 ptr_void_ftype = build_pointer_type (void_ftype);
414
415 /* Now declare run-time functions. */
416 malloc_decl
417 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
418 build_function_type_list (ptr_type_node, sizetype,
419 NULL_TREE),
420 NULL_TREE, is_default, true, true, true, false,
421 false, NULL, Empty);
422 DECL_IS_MALLOC (malloc_decl) = 1;
423
424 free_decl
425 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
426 build_function_type_list (void_type_node,
427 ptr_type_node, NULL_TREE),
428 NULL_TREE, is_default, true, true, true, false,
429 false, NULL, Empty);
430
431 realloc_decl
432 = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE,
433 build_function_type_list (ptr_type_node,
434 ptr_type_node, sizetype,
435 NULL_TREE),
436 NULL_TREE, is_default, true, true, true, false,
437 false, NULL, Empty);
438
439 /* This is used for 64-bit multiplication with overflow checking. */
440 int64_type = gnat_type_for_size (64, 0);
441 mulv64_decl
442 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
443 build_function_type_list (int64_type, int64_type,
444 int64_type, NULL_TREE),
445 NULL_TREE, is_default, true, true, true, false,
446 false, NULL, Empty);
447
448 if (Enable_128bit_Types)
449 {
450 tree int128_type = gnat_type_for_size (128, 0);
451 mulv128_decl
452 = create_subprog_decl (get_identifier ("__gnat_mulv128"), NULL_TREE,
453 build_function_type_list (int128_type,
454 int128_type,
455 int128_type,
456 NULL_TREE),
457 NULL_TREE, is_default, true, true, true, false,
458 false, NULL, Empty);
459 }
460
461 /* Name of the _Parent field in tagged record types. */
462 parent_name_id = get_identifier (Get_Name_String (Name_uParent));
463
464 /* Name of the Exception_Data type defined in System.Standard_Library. */
465 exception_data_name_id
466 = get_identifier ("system__standard_library__exception_data");
467
468 /* Make the types and functions used for exception processing. */
469 except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type));
470
471 jmpbuf_type
472 = build_array_type (gnat_type_for_mode (Pmode, 0),
473 build_index_type (size_int (5)));
474 record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
475 jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
476
477 /* Functions to get and set the jumpbuf pointer for the current thread. */
478 get_jmpbuf_decl
479 = create_subprog_decl
480 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
481 NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
482 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
483
484 set_jmpbuf_decl
485 = create_subprog_decl
486 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
487 NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
488 NULL_TREE),
489 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
490
491 get_excptr_decl
492 = create_subprog_decl
493 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
494 build_function_type_list (build_pointer_type (except_type_node),
495 NULL_TREE),
496 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
497
498 not_handled_by_others_decl = get_identifier ("not_handled_by_others");
499 for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
500 if (DECL_NAME (t) == not_handled_by_others_decl)
501 {
502 not_handled_by_others_decl = t;
503 break;
504 }
505 gcc_assert (DECL_P (not_handled_by_others_decl));
506
507 /* setjmp returns an integer and has one operand, which is a pointer to
508 a jmpbuf. */
509 setjmp_decl
510 = create_subprog_decl
511 (get_identifier ("__builtin_setjmp"), NULL_TREE,
512 build_function_type_list (integer_type_node, jmpbuf_ptr_type,
513 NULL_TREE),
514 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
515 set_decl_built_in_function (setjmp_decl, BUILT_IN_NORMAL, BUILT_IN_SETJMP);
516
517 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
518 address. */
519 update_setjmp_buf_decl
520 = create_subprog_decl
521 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
522 build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
523 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
524 set_decl_built_in_function (update_setjmp_buf_decl, BUILT_IN_NORMAL,
525 BUILT_IN_UPDATE_SETJMP_BUF);
526
527 /* Indicate that it never returns. */
528 ftype = build_function_type_list (void_type_node,
529 build_pointer_type (except_type_node),
530 NULL_TREE);
531 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
532 raise_nodefer_decl
533 = create_subprog_decl
534 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, ftype,
535 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
536
537 set_exception_parameter_decl
538 = create_subprog_decl
539 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
540 build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
541 NULL_TREE),
542 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
543
544 /* Hooks to call when entering/leaving an exception handler. */
545 ftype = build_function_type_list (ptr_type_node,
546 ptr_type_node, NULL_TREE);
547 begin_handler_decl
548 = create_subprog_decl (get_identifier ("__gnat_begin_handler_v1"),
549 NULL_TREE, ftype, NULL_TREE,
550 is_default, true, true, true, false, false, NULL,
551 Empty);
552 /* __gnat_begin_handler_v1 is not a dummy procedure, but we arrange
553 for it not to throw. */
554 TREE_NOTHROW (begin_handler_decl) = 1;
555
556 ftype = build_function_type_list (ptr_type_node,
557 ptr_type_node, ptr_type_node,
558 ptr_type_node, NULL_TREE);
559 end_handler_decl
560 = create_subprog_decl (get_identifier ("__gnat_end_handler_v1"), NULL_TREE,
561 ftype, NULL_TREE,
562 is_default, true, true, true, false, false, NULL,
563 Empty);
564
565 ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
566 unhandled_except_decl
567 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
568 NULL_TREE, ftype, NULL_TREE,
569 is_default, true, true, true, false, false, NULL,
570 Empty);
571
572 /* Indicate that it never returns. */
573 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
574 reraise_zcx_decl
575 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
576 ftype, NULL_TREE,
577 is_default, true, true, true, false, false, NULL,
578 Empty);
579
580 /* Dummy objects to materialize "others" and "all others" in the exception
581 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
582 the types to use. */
583 others_decl
584 = create_var_decl (get_identifier ("OTHERS"),
585 get_identifier ("__gnat_others_value"),
586 char_type_node, NULL_TREE,
587 true, false, true, false, false, true, false,
588 NULL, Empty);
589
590 all_others_decl
591 = create_var_decl (get_identifier ("ALL_OTHERS"),
592 get_identifier ("__gnat_all_others_value"),
593 char_type_node, NULL_TREE,
594 true, false, true, false, false, true, false,
595 NULL, Empty);
596
597 unhandled_others_decl
598 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
599 get_identifier ("__gnat_unhandled_others_value"),
600 char_type_node, NULL_TREE,
601 true, false, true, false, false, true, false,
602 NULL, Empty);
603
604 /* If in no exception handlers mode, all raise statements are redirected to
605 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
606 this procedure will never be called in this mode. */
607 if (No_Exception_Handlers_Set ())
608 {
609 /* Indicate that it never returns. */
610 ftype = build_function_type_list (void_type_node,
611 build_pointer_type (char_type_node),
612 integer_type_node, NULL_TREE);
613 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
614 tree decl
615 = create_subprog_decl
616 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, ftype,
617 NULL_TREE, is_default, true, true, true, false, false, NULL,
618 Empty);
619 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
620 gnat_raise_decls[i] = decl;
621 }
622 else
623 {
624 /* Otherwise, make one decl for each exception reason. */
625 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
626 gnat_raise_decls[i] = build_raise_check (i, exception_simple);
627 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
628 gnat_raise_decls_ext[i]
629 = build_raise_check (i,
630 i == CE_Index_Check_Failed
631 || i == CE_Range_Check_Failed
632 || i == CE_Invalid_Data
633 ? exception_range : exception_column);
634 }
635
636 /* Build the special descriptor type and its null node if needed. */
637 if (TARGET_VTABLE_USES_DESCRIPTORS)
638 {
639 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
640 tree field_list = NULL_TREE;
641 int j;
642 vec<constructor_elt, va_gc> *null_vec = NULL;
643 constructor_elt *elt;
644
645 fdesc_type_node = make_node (RECORD_TYPE);
646 vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS, true);
647 elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
648
649 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
650 {
651 tree field
652 = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
653 NULL_TREE, NULL_TREE, 0, 1);
654 DECL_CHAIN (field) = field_list;
655 field_list = field;
656 elt->index = field;
657 elt->value = null_node;
658 elt--;
659 }
660
661 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
662 record_builtin_type ("descriptor", fdesc_type_node, true);
663 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
664 }
665
666 longest_float_type_node
667 = get_unpadded_type (Base_Type (standard_long_long_float));
668
669 main_identifier_node = get_identifier ("main");
670
671 /* If we are using the GCC exception mechanism, let GCC know. */
672 if (Back_End_Exceptions ())
673 gnat_init_gcc_eh ();
674
675 /* Initialize the GCC support for FP operations. */
676 gnat_init_gcc_fp ();
677
678 /* Install the builtins we might need, either internally or as user-available
679 facilities for Intrinsic imports. Note that this must be done after the
680 GCC exception mechanism is initialized. */
681 gnat_install_builtins ();
682
683 vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
684
685 gnu_constraint_error_label_stack.safe_push (Empty);
686 gnu_storage_error_label_stack.safe_push (Empty);
687 gnu_program_error_label_stack.safe_push (Empty);
688
689 /* Process any Pragma Ident for the main unit. */
690 if (Present (Ident_String (Main_Unit)))
691 targetm.asm_out.output_ident
692 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
693
694 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
695 if (No_Strict_Aliasing_CP)
696 flag_strict_aliasing = 0;
697
698 /* Save the current optimization options again after the above possible
699 global_options changes. */
700 optimization_default_node
701 = build_optimization_node (&global_options, &global_options_set);
702 optimization_current_node = optimization_default_node;
703
704 /* Now translate the compilation unit proper. */
705 Compilation_Unit_to_gnu (gnat_root);
706
707 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
708 the very end to avoid having to second-guess the front-end when we run
709 into dummy nodes during the regular processing. */
710 for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++)
711 validate_unchecked_conversion (gnat_iter);
712 gnat_validate_uc_list.release ();
713
714 /* Finally see if we have any elaboration procedures to deal with. */
715 for (info = elab_info_list; info; info = info->next)
716 {
717 tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
718
719 /* We should have a BIND_EXPR but it may not have any statements in it.
720 If it doesn't have any, we have nothing to do except for setting the
721 flag on the GNAT node. Otherwise, process the function as others. */
722 tree gnu_stmts = gnu_body;
723 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
724 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
725 if (!gnu_stmts || empty_stmt_list_p (gnu_stmts))
726 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
727 else
728 {
729 begin_subprog_body (info->elab_proc);
730 end_subprog_body (gnu_body);
731 rest_of_subprog_body_compilation (info->elab_proc);
732 }
733 }
734
735 /* Destroy ourselves. */
736 file_map = NULL;
737 destroy_gnat_decl ();
738 destroy_gnat_utils ();
739
740 /* We cannot track the location of errors past this point. */
741 Current_Error_Node = Empty;
742 }
743
744 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
745 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
746
747 static tree
build_raise_check(int check,enum exception_info_kind kind)748 build_raise_check (int check, enum exception_info_kind kind)
749 {
750 tree result, ftype;
751 const char pfx[] = "__gnat_rcheck_";
752
753 strcpy (Name_Buffer, pfx);
754 Name_Len = sizeof (pfx) - 1;
755 Get_RT_Exception_Name (check);
756
757 if (kind == exception_simple)
758 {
759 Name_Buffer[Name_Len] = 0;
760 ftype
761 = build_function_type_list (void_type_node,
762 build_pointer_type (char_type_node),
763 integer_type_node, NULL_TREE);
764 }
765 else
766 {
767 tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
768
769 strcpy (Name_Buffer + Name_Len, "_ext");
770 Name_Buffer[Name_Len + 4] = 0;
771 ftype
772 = build_function_type_list (void_type_node,
773 build_pointer_type (char_type_node),
774 integer_type_node, integer_type_node,
775 t, t, NULL_TREE);
776 }
777
778 /* Indicate that it never returns. */
779 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
780 result
781 = create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, ftype,
782 NULL_TREE, is_default, true, true, true, false,
783 false, NULL, Empty);
784
785 return result;
786 }
787
788 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
789 an N_Attribute_Reference. */
790
791 static int
lvalue_required_for_attribute_p(Node_Id gnat_node)792 lvalue_required_for_attribute_p (Node_Id gnat_node)
793 {
794 switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
795 {
796 case Attr_Pred:
797 case Attr_Succ:
798 case Attr_First:
799 case Attr_Last:
800 case Attr_Range_Length:
801 case Attr_Length:
802 case Attr_Object_Size:
803 case Attr_Size:
804 case Attr_Value_Size:
805 case Attr_Component_Size:
806 case Attr_Descriptor_Size:
807 case Attr_Max_Size_In_Storage_Elements:
808 case Attr_Min:
809 case Attr_Max:
810 case Attr_Null_Parameter:
811 case Attr_Passed_By_Reference:
812 case Attr_Mechanism_Code:
813 case Attr_Machine:
814 case Attr_Model:
815 return 0;
816
817 case Attr_Address:
818 case Attr_Access:
819 case Attr_Unchecked_Access:
820 case Attr_Unrestricted_Access:
821 case Attr_Code_Address:
822 case Attr_Pool_Address:
823 case Attr_Alignment:
824 case Attr_Bit_Position:
825 case Attr_Position:
826 case Attr_First_Bit:
827 case Attr_Last_Bit:
828 case Attr_Bit:
829 case Attr_Asm_Input:
830 case Attr_Asm_Output:
831 default:
832 return 1;
833 }
834 }
835
836 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
837 is the type that will be used for GNAT_NODE in the translated GNU tree.
838 CONSTANT indicates whether the underlying object represented by GNAT_NODE
839 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
840 whether its value is the address of another constant. If it isn't, then
841 ADDRESS_OF_CONSTANT is ignored.
842
843 The function climbs up the GNAT tree starting from the node and returns 1
844 upon encountering a node that effectively requires an lvalue downstream.
845 It returns int instead of bool to facilitate usage in non-purely binary
846 logic contexts. */
847
848 static int
lvalue_required_p(Node_Id gnat_node,tree gnu_type,bool constant,bool address_of_constant)849 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
850 bool address_of_constant)
851 {
852 Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
853
854 switch (Nkind (gnat_parent))
855 {
856 case N_Reference:
857 return 1;
858
859 case N_Attribute_Reference:
860 return lvalue_required_for_attribute_p (gnat_parent);
861
862 case N_Parameter_Association:
863 case N_Function_Call:
864 case N_Procedure_Call_Statement:
865 /* If the parameter is by reference, an lvalue is required. */
866 return (!constant
867 || must_pass_by_ref (gnu_type)
868 || default_pass_by_ref (gnu_type));
869
870 case N_Indexed_Component:
871 /* Only the array expression can require an lvalue. */
872 if (Prefix (gnat_parent) != gnat_node)
873 return 0;
874
875 /* ??? Consider that referencing an indexed component with a variable
876 index forces the whole aggregate to memory. Note that testing only
877 for literals is conservative, any static expression in the RM sense
878 could probably be accepted with some additional work. */
879 for (gnat_temp = First (Expressions (gnat_parent));
880 Present (gnat_temp);
881 gnat_temp = Next (gnat_temp))
882 if (Nkind (gnat_temp) != N_Character_Literal
883 && Nkind (gnat_temp) != N_Integer_Literal
884 && !(Is_Entity_Name (gnat_temp)
885 && Ekind (Entity (gnat_temp)) == E_Enumeration_Literal))
886 return 1;
887
888 /* ... fall through ... */
889
890 case N_Selected_Component:
891 case N_Slice:
892 /* Only the prefix expression can require an lvalue. */
893 if (Prefix (gnat_parent) != gnat_node)
894 return 0;
895
896 return lvalue_required_p (gnat_parent,
897 get_unpadded_type (Etype (gnat_parent)),
898 constant, address_of_constant);
899
900 case N_Object_Renaming_Declaration:
901 /* We need to preserve addresses through a renaming. */
902 return 1;
903
904 case N_Object_Declaration:
905 /* We cannot use a constructor if this is an atomic object because
906 the actual assignment might end up being done component-wise. */
907 return (!constant
908 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
909 && Is_Full_Access (Defining_Entity (gnat_parent)))
910 /* We don't use a constructor if this is a class-wide object
911 because the effective type of the object is the equivalent
912 type of the class-wide subtype and it smashes most of the
913 data into an array of bytes to which we cannot convert. */
914 || Ekind ((Etype (Defining_Entity (gnat_parent))))
915 == E_Class_Wide_Subtype);
916
917 case N_Assignment_Statement:
918 /* We cannot use a constructor if the LHS is an atomic object because
919 the actual assignment might end up being done component-wise. */
920 return (!constant
921 || Name (gnat_parent) == gnat_node
922 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
923 && Is_Entity_Name (Name (gnat_parent))
924 && Is_Full_Access (Entity (Name (gnat_parent)))));
925
926 case N_Unchecked_Type_Conversion:
927 if (!constant)
928 return 1;
929
930 /* ... fall through ... */
931
932 case N_Type_Conversion:
933 case N_Qualified_Expression:
934 /* We must look through all conversions because we may need to bypass
935 an intermediate conversion that is meant to be purely formal. */
936 return lvalue_required_p (gnat_parent,
937 get_unpadded_type (Etype (gnat_parent)),
938 constant, address_of_constant);
939
940 case N_Explicit_Dereference:
941 /* We look through dereferences for address of constant because we need
942 to handle the special cases listed above. */
943 if (constant && address_of_constant)
944 return lvalue_required_p (gnat_parent,
945 get_unpadded_type (Etype (gnat_parent)),
946 true, false);
947
948 /* ... fall through ... */
949
950 default:
951 return 0;
952 }
953
954 gcc_unreachable ();
955 }
956
957 /* Return true if an lvalue should be used for GNAT_NODE. GNU_TYPE is the type
958 that will be used for GNAT_NODE in the translated GNU tree and is assumed to
959 be an aggregate type.
960
961 The function climbs up the GNAT tree starting from the node and returns true
962 upon encountering a node that makes it doable to decide. lvalue_required_p
963 should have been previously invoked on the arguments and returned false. */
964
965 static bool
lvalue_for_aggregate_p(Node_Id gnat_node,tree gnu_type)966 lvalue_for_aggregate_p (Node_Id gnat_node, tree gnu_type)
967 {
968 Node_Id gnat_parent = Parent (gnat_node);
969
970 switch (Nkind (gnat_parent))
971 {
972 case N_Parameter_Association:
973 case N_Function_Call:
974 case N_Procedure_Call_Statement:
975 /* Even if the parameter is by copy, prefer an lvalue. */
976 return true;
977
978 case N_Simple_Return_Statement:
979 /* Likewise for a return value. */
980 return true;
981
982 case N_Indexed_Component:
983 case N_Selected_Component:
984 /* If an elementary component is used, take it from the constant. */
985 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_parent))))
986 return false;
987
988 /* ... fall through ... */
989
990 case N_Slice:
991 return lvalue_for_aggregate_p (gnat_parent,
992 get_unpadded_type (Etype (gnat_parent)));
993
994 case N_Object_Declaration:
995 /* For an aggregate object declaration, return false consistently. */
996 return false;
997
998 case N_Assignment_Statement:
999 /* For an aggregate assignment, decide based on the size. */
1000 {
1001 const HOST_WIDE_INT size = int_size_in_bytes (gnu_type);
1002 return size < 0 || size >= param_large_stack_frame / 4;
1003 }
1004
1005 case N_Unchecked_Type_Conversion:
1006 case N_Type_Conversion:
1007 case N_Qualified_Expression:
1008 return lvalue_for_aggregate_p (gnat_parent,
1009 get_unpadded_type (Etype (gnat_parent)));
1010
1011 case N_Allocator:
1012 /* We should only reach here through the N_Qualified_Expression case.
1013 Force an lvalue for aggregate types since a block-copy to the newly
1014 allocated area of memory is made. */
1015 return true;
1016
1017 default:
1018 return false;
1019 }
1020
1021 gcc_unreachable ();
1022 }
1023
1024
1025 /* Return true if T is a constant DECL node that can be safely replaced
1026 by its initializer. */
1027
1028 static bool
constant_decl_with_initializer_p(tree t)1029 constant_decl_with_initializer_p (tree t)
1030 {
1031 if (!TREE_CONSTANT (t) || !DECL_P (t) || !DECL_INITIAL (t))
1032 return false;
1033
1034 /* Return false for aggregate types that contain a placeholder since
1035 their initializers cannot be manipulated easily. */
1036 if (AGGREGATE_TYPE_P (TREE_TYPE (t))
1037 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t))
1038 && type_contains_placeholder_p (TREE_TYPE (t)))
1039 return false;
1040
1041 return true;
1042 }
1043
1044 /* Return an expression equivalent to EXP but where constant DECL nodes
1045 have been replaced by their initializer. */
1046
1047 static tree
fold_constant_decl_in_expr(tree exp)1048 fold_constant_decl_in_expr (tree exp)
1049 {
1050 enum tree_code code = TREE_CODE (exp);
1051 tree op0;
1052
1053 switch (code)
1054 {
1055 case CONST_DECL:
1056 case VAR_DECL:
1057 if (!constant_decl_with_initializer_p (exp))
1058 return exp;
1059
1060 return DECL_INITIAL (exp);
1061
1062 case COMPONENT_REF:
1063 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1064 if (op0 == TREE_OPERAND (exp, 0))
1065 return exp;
1066
1067 return fold_build3 (COMPONENT_REF, TREE_TYPE (exp), op0,
1068 TREE_OPERAND (exp, 1), NULL_TREE);
1069
1070 case BIT_FIELD_REF:
1071 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1072 if (op0 == TREE_OPERAND (exp, 0))
1073 return exp;
1074
1075 return fold_build3 (BIT_FIELD_REF, TREE_TYPE (exp), op0,
1076 TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
1077
1078 case ARRAY_REF:
1079 case ARRAY_RANGE_REF:
1080 /* If the index is not itself constant, then nothing can be folded. */
1081 if (!TREE_CONSTANT (TREE_OPERAND (exp, 1)))
1082 return exp;
1083 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1084 if (op0 == TREE_OPERAND (exp, 0))
1085 return exp;
1086
1087 return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
1088 TREE_OPERAND (exp, 2), NULL_TREE));
1089
1090 case REALPART_EXPR:
1091 case IMAGPART_EXPR:
1092 case VIEW_CONVERT_EXPR:
1093 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1094 if (op0 == TREE_OPERAND (exp, 0))
1095 return exp;
1096
1097 return fold_build1 (code, TREE_TYPE (exp), op0);
1098
1099 default:
1100 return exp;
1101 }
1102
1103 gcc_unreachable ();
1104 }
1105
1106 /* Return true if TYPE and DEF_TYPE are compatible GNAT types for Gigi. */
1107
1108 static bool
Gigi_Types_Compatible(Entity_Id type,Entity_Id def_type)1109 Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type)
1110 {
1111 /* The trivial case. */
1112 if (type == def_type)
1113 return true;
1114
1115 /* A class-wide type is equivalent to a subtype of itself. */
1116 if (Is_Class_Wide_Type (type))
1117 return true;
1118
1119 /* A packed array type is compatible with its implementation type. */
1120 if (Is_Packed (def_type) && type == Packed_Array_Impl_Type (def_type))
1121 return true;
1122
1123 /* If both types are Itypes, one may be a copy of the other. */
1124 if (Is_Itype (def_type) && Is_Itype (type))
1125 return true;
1126
1127 /* If the type is incomplete and comes from a limited context, then also
1128 consider its non-limited view. */
1129 if (Is_Incomplete_Type (def_type)
1130 && From_Limited_With (def_type)
1131 && Present (Non_Limited_View (def_type)))
1132 return Gigi_Types_Compatible (type, Non_Limited_View (def_type));
1133
1134 /* If the type is incomplete/private, then also consider its full view. */
1135 if (Is_Incomplete_Or_Private_Type (def_type)
1136 && Present (Full_View (def_type)))
1137 return Gigi_Types_Compatible (type, Full_View (def_type));
1138
1139 return false;
1140 }
1141
1142 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1143 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1144 to where we should place the result type. */
1145
1146 static tree
Identifier_to_gnu(Node_Id gnat_node,tree * gnu_result_type_p)1147 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
1148 {
1149 /* The entity of GNAT_NODE and its type. */
1150 Node_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier
1151 || Nkind (gnat_node) == N_Defining_Operator_Symbol)
1152 ? gnat_node : Entity (gnat_node);
1153 Node_Id gnat_entity_type = Etype (gnat_entity);
1154 /* If GNAT_NODE is a constant, whether we should use the initialization
1155 value instead of the constant entity, typically for scalars with an
1156 address clause when the parent doesn't require an lvalue. */
1157 bool use_constant_initializer = false;
1158 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1159 specific circumstances only, so evaluated lazily. < 0 means
1160 unknown, > 0 means known true, 0 means known false. */
1161 int require_lvalue = -1;
1162 Node_Id gnat_result_type;
1163 tree gnu_result, gnu_result_type;
1164
1165 /* If the Etype of this node is not the same as that of the Entity, then
1166 something went wrong, probably in generic instantiation. However, this
1167 does not apply to types. Since we sometime have strange Ekind's, just
1168 do this test for objects, except for discriminants because their type
1169 may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */
1170 gcc_assert (!Is_Object (gnat_entity)
1171 || Ekind (gnat_entity) == E_Discriminant
1172 || Etype (gnat_node) == gnat_entity_type
1173 || Gigi_Types_Compatible (Etype (gnat_node), gnat_entity_type));
1174
1175 /* If this is a reference to a deferred constant whose partial view is an
1176 unconstrained private type, the proper type is on the full view of the
1177 constant, not on the full view of the type, which may be unconstrained.
1178
1179 This may be a reference to a type, for example in the prefix of the
1180 attribute Position, generated for dispatching code (see Make_DT in
1181 exp_disp,adb). In that case we need the type itself, not is parent,
1182 in particular if it is a derived type */
1183 if (Ekind (gnat_entity) == E_Constant
1184 && Is_Private_Type (gnat_entity_type)
1185 && (Has_Unknown_Discriminants (gnat_entity_type)
1186 || (Present (Full_View (gnat_entity_type))
1187 && Has_Discriminants (Full_View (gnat_entity_type))))
1188 && Present (Full_View (gnat_entity)))
1189 {
1190 gnat_entity = Full_View (gnat_entity);
1191 gnat_result_type = Etype (gnat_entity);
1192 }
1193 else
1194 {
1195 /* We use the Actual_Subtype only if it has already been elaborated,
1196 as we may be invoked precisely during its elaboration, otherwise
1197 the Etype. Avoid using it for packed arrays to simplify things,
1198 except in a return statement because we need the actual size and
1199 the front-end does not make it explicit in this case. */
1200 if ((Ekind (gnat_entity) == E_Constant
1201 || Ekind (gnat_entity) == E_Variable
1202 || Is_Formal (gnat_entity))
1203 && !(Is_Array_Type (Etype (gnat_entity))
1204 && Present (Packed_Array_Impl_Type (Etype (gnat_entity)))
1205 && Nkind (Parent (gnat_node)) != N_Simple_Return_Statement)
1206 && Present (Actual_Subtype (gnat_entity))
1207 && present_gnu_tree (Actual_Subtype (gnat_entity)))
1208 gnat_result_type = Actual_Subtype (gnat_entity);
1209 else
1210 gnat_result_type = Etype (gnat_node);
1211 }
1212
1213 /* Expand the type of this identifier first, in case it is an enumeral
1214 literal, which only get made when the type is expanded. There is no
1215 order-of-elaboration issue here. */
1216 gnu_result_type = get_unpadded_type (gnat_result_type);
1217
1218 /* If this is a non-imported elementary constant with an address clause,
1219 retrieve the value instead of a pointer to be dereferenced unless
1220 an lvalue is required. This is generally more efficient and actually
1221 required if this is a static expression because it might be used
1222 in a context where a dereference is inappropriate, such as a case
1223 statement alternative or a record discriminant. There is no possible
1224 volatile-ness short-circuit here since Volatile constants must be
1225 imported per C.6. */
1226 if (Ekind (gnat_entity) == E_Constant
1227 && Is_Elementary_Type (gnat_result_type)
1228 && !Is_Imported (gnat_entity)
1229 && Present (Address_Clause (gnat_entity)))
1230 {
1231 require_lvalue
1232 = lvalue_required_p (gnat_node, gnu_result_type, true, false);
1233 use_constant_initializer = !require_lvalue;
1234 }
1235
1236 if (use_constant_initializer)
1237 {
1238 /* If this is a deferred constant, the initializer is attached to
1239 the full view. */
1240 if (Present (Full_View (gnat_entity)))
1241 gnat_entity = Full_View (gnat_entity);
1242
1243 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
1244 }
1245 else
1246 gnu_result = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
1247
1248 /* Some objects (such as parameters passed by reference, globals of
1249 variable size, and renamed objects) actually represent the address
1250 of the object. In that case, we must do the dereference. Likewise,
1251 deal with parameters to foreign convention subprograms. */
1252 if (DECL_P (gnu_result)
1253 && (DECL_BY_REF_P (gnu_result)
1254 || (TREE_CODE (gnu_result) == PARM_DECL
1255 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
1256 {
1257 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1258
1259 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1260 if (TREE_CODE (gnu_result) == PARM_DECL
1261 && DECL_BY_COMPONENT_PTR_P (gnu_result))
1262 gnu_result
1263 = convert (build_pointer_type (gnu_result_type), gnu_result);
1264
1265 /* If it's a CONST_DECL, return the underlying constant like below. */
1266 else if (TREE_CODE (gnu_result) == CONST_DECL
1267 && !(DECL_CONST_ADDRESS_P (gnu_result)
1268 && lvalue_required_p (gnat_node, gnu_result_type, true,
1269 true)))
1270 gnu_result = DECL_INITIAL (gnu_result);
1271
1272 /* Do the final dereference. */
1273 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1274
1275 if ((TREE_CODE (gnu_result) == INDIRECT_REF
1276 || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
1277 && No (Address_Clause (gnat_entity)))
1278 TREE_THIS_NOTRAP (gnu_result) = 1;
1279
1280 if (read_only)
1281 TREE_READONLY (gnu_result) = 1;
1282 }
1283
1284 /* If we have a constant declaration and its initializer, try to return the
1285 latter to avoid the need to call fold in lots of places and the need for
1286 elaboration code if this identifier is used as an initializer itself. */
1287 if (constant_decl_with_initializer_p (gnu_result))
1288 {
1289 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1290 && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1291 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1292 && DECL_CONST_ADDRESS_P (gnu_result));
1293
1294 /* If there is a (corresponding) variable or this is the address of a
1295 constant, we only want to return the initializer if an lvalue isn't
1296 required. Evaluate this now if we have not already done so. */
1297 if ((!constant_only || address_of_constant) && require_lvalue < 0)
1298 require_lvalue
1299 = lvalue_required_p (gnat_node, gnu_result_type, true,
1300 address_of_constant)
1301 || (AGGREGATE_TYPE_P (gnu_result_type)
1302 && lvalue_for_aggregate_p (gnat_node, gnu_result_type));
1303
1304 /* Finally retrieve the initializer if this is deemed valid. */
1305 if ((constant_only && !address_of_constant) || !require_lvalue)
1306 gnu_result = DECL_INITIAL (gnu_result);
1307 }
1308
1309 /* But for a constant renaming we couldn't do that incrementally for its
1310 definition because of the need to return an lvalue so, if the present
1311 context doesn't itself require an lvalue, we try again here. */
1312 else if (Ekind (gnat_entity) == E_Constant
1313 && Is_Elementary_Type (gnat_result_type)
1314 && Present (Renamed_Object (gnat_entity)))
1315 {
1316 if (require_lvalue < 0)
1317 require_lvalue
1318 = lvalue_required_p (gnat_node, gnu_result_type, true, false);
1319 if (!require_lvalue)
1320 gnu_result = fold_constant_decl_in_expr (gnu_result);
1321 }
1322
1323 /* The GNAT tree has the type of a function set to its result type, so we
1324 adjust here. Also use the type of the result if the Etype is a subtype
1325 that is nominally unconstrained. Likewise if this is a deferred constant
1326 of a discriminated type whose full view can be elaborated statically, to
1327 avoid problematic conversions to the nominal subtype. But remove any
1328 padding from the resulting type. */
1329 if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result))
1330 || Is_Constr_Subt_For_UN_Aliased (gnat_result_type)
1331 || (Ekind (gnat_entity) == E_Constant
1332 && Present (Full_View (gnat_entity))
1333 && Has_Discriminants (gnat_result_type)
1334 && TREE_CODE (gnu_result) == CONSTRUCTOR))
1335 {
1336 gnu_result_type = TREE_TYPE (gnu_result);
1337 if (TYPE_IS_PADDING_P (gnu_result_type))
1338 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1339 }
1340
1341 *gnu_result_type_p = gnu_result_type;
1342
1343 return gnu_result;
1344 }
1345
1346 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1347 any statements we generate. */
1348
1349 static tree
Pragma_to_gnu(Node_Id gnat_node)1350 Pragma_to_gnu (Node_Id gnat_node)
1351 {
1352 tree gnu_result = alloc_stmt_list ();
1353 Node_Id gnat_temp;
1354
1355 /* Check for (and ignore) unrecognized pragmas. */
1356 if (!Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1357 return gnu_result;
1358
1359 const unsigned char id
1360 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
1361
1362 /* Save the expression of pragma Compile_Time_{Error|Warning} for later. */
1363 if (id == Pragma_Compile_Time_Error || id == Pragma_Compile_Time_Warning)
1364 {
1365 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1366 gnat_compile_time_expr_list.safe_push (Expression (gnat_temp));
1367 return gnu_result;
1368 }
1369
1370 /* Stop there if we are just annotating types. */
1371 if (type_annotate_only)
1372 return gnu_result;
1373
1374 switch (id)
1375 {
1376 case Pragma_Inspection_Point:
1377 /* Do nothing at top level: all such variables are already viewable. */
1378 if (global_bindings_p ())
1379 break;
1380
1381 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1382 Present (gnat_temp);
1383 gnat_temp = Next (gnat_temp))
1384 {
1385 Node_Id gnat_expr = Expression (gnat_temp);
1386 tree gnu_expr = gnat_to_gnu (gnat_expr);
1387 tree asm_constraint = NULL_TREE;
1388 #ifdef ASM_COMMENT_START
1389 char *comment;
1390 #endif
1391 gnu_expr = maybe_unconstrained_array (gnu_expr);
1392 gnat_mark_addressable (gnu_expr);
1393
1394 #ifdef ASM_COMMENT_START
1395 comment = concat (ASM_COMMENT_START,
1396 " inspection point: ",
1397 Get_Name_String (Chars (gnat_expr)),
1398 " is at %0",
1399 NULL);
1400 asm_constraint = build_string (strlen (comment), comment);
1401 free (comment);
1402 #endif
1403 gnu_expr = build5 (ASM_EXPR, void_type_node,
1404 asm_constraint,
1405 NULL_TREE,
1406 tree_cons
1407 (build_tree_list (NULL_TREE,
1408 build_string (1, "m")),
1409 gnu_expr, NULL_TREE),
1410 NULL_TREE, NULL_TREE);
1411 ASM_VOLATILE_P (gnu_expr) = 1;
1412 set_expr_location_from_node (gnu_expr, gnat_node);
1413 append_to_statement_list (gnu_expr, &gnu_result);
1414 }
1415 break;
1416
1417 case Pragma_Loop_Optimize:
1418 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1419 Present (gnat_temp);
1420 gnat_temp = Next (gnat_temp))
1421 {
1422 tree gnu_loop_stmt = gnu_loop_stack->last ()->stmt;
1423
1424 switch (Chars (Expression (gnat_temp)))
1425 {
1426 case Name_Ivdep:
1427 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
1428 break;
1429
1430 case Name_No_Unroll:
1431 LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1;
1432 break;
1433
1434 case Name_Unroll:
1435 LOOP_STMT_UNROLL (gnu_loop_stmt) = 1;
1436 break;
1437
1438 case Name_No_Vector:
1439 LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1;
1440 break;
1441
1442 case Name_Vector:
1443 LOOP_STMT_VECTOR (gnu_loop_stmt) = 1;
1444 break;
1445
1446 default:
1447 gcc_unreachable ();
1448 }
1449 }
1450 break;
1451
1452 case Pragma_Optimize:
1453 switch (Chars (Expression
1454 (First (Pragma_Argument_Associations (gnat_node)))))
1455 {
1456 case Name_Off:
1457 if (optimize)
1458 post_error ("must specify -O0?", gnat_node);
1459 break;
1460
1461 case Name_Space:
1462 if (!optimize_size)
1463 post_error ("must specify -Os?", gnat_node);
1464 break;
1465
1466 case Name_Time:
1467 if (!optimize)
1468 post_error ("insufficient -O value?", gnat_node);
1469 break;
1470
1471 default:
1472 gcc_unreachable ();
1473 }
1474 break;
1475
1476 case Pragma_Reviewable:
1477 if (write_symbols == NO_DEBUG)
1478 post_error ("must specify -g?", gnat_node);
1479 break;
1480
1481 case Pragma_Warning_As_Error:
1482 case Pragma_Warnings:
1483 {
1484 Node_Id gnat_expr;
1485 /* Preserve the location of the pragma. */
1486 const location_t location = input_location;
1487 struct cl_option_handlers handlers;
1488 unsigned int option_index;
1489 diagnostic_t kind;
1490 bool imply;
1491
1492 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1493
1494 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1495 if (Nkind (Expression (gnat_temp)) == N_String_Literal)
1496 {
1497 switch (id)
1498 {
1499 case Pragma_Warning_As_Error:
1500 kind = DK_ERROR;
1501 imply = false;
1502 break;
1503
1504 case Pragma_Warnings:
1505 kind = DK_WARNING;
1506 imply = true;
1507 break;
1508
1509 default:
1510 gcc_unreachable ();
1511 }
1512
1513 gnat_expr = Expression (gnat_temp);
1514 }
1515
1516 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1517 else if (Nkind (Expression (gnat_temp)) == N_Identifier)
1518 {
1519 switch (Chars (Expression (gnat_temp)))
1520 {
1521 case Name_Off:
1522 kind = DK_IGNORED;
1523 break;
1524
1525 case Name_On:
1526 kind = DK_WARNING;
1527 break;
1528
1529 default:
1530 gcc_unreachable ();
1531 }
1532
1533 /* Deal with optional pattern (but ignore Reason => "..."). */
1534 if (Present (Next (gnat_temp))
1535 && Chars (Next (gnat_temp)) != Name_Reason)
1536 {
1537 /* pragma Warnings (On | Off, Name) is handled differently. */
1538 if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal)
1539 break;
1540
1541 gnat_expr = Expression (Next (gnat_temp));
1542 }
1543 else
1544 {
1545 gnat_expr = Empty;
1546
1547 /* For pragma Warnings (Off), we save the current state... */
1548 if (kind == DK_IGNORED)
1549 diagnostic_push_diagnostics (global_dc, location);
1550
1551 /* ...so that, for pragma Warnings (On), we do not enable all
1552 the warnings but just restore the previous state. */
1553 else
1554 {
1555 diagnostic_pop_diagnostics (global_dc, location);
1556 break;
1557 }
1558 }
1559
1560 imply = false;
1561 }
1562
1563 else
1564 gcc_unreachable ();
1565
1566 /* This is the same implementation as in the C family of compilers. */
1567 const unsigned int lang_mask = CL_Ada | CL_COMMON;
1568 const char *arg = NULL;
1569 if (Present (gnat_expr))
1570 {
1571 tree gnu_expr = gnat_to_gnu (gnat_expr);
1572 const char *option_string = TREE_STRING_POINTER (gnu_expr);
1573 const int len = TREE_STRING_LENGTH (gnu_expr);
1574 if (len < 3 || option_string[0] != '-' || option_string[1] != 'W')
1575 break;
1576 option_index = find_opt (option_string + 1, lang_mask);
1577 if (option_index == OPT_SPECIAL_unknown)
1578 {
1579 post_error ("?unknown -W switch", gnat_node);
1580 break;
1581 }
1582 else if (!(cl_options[option_index].flags & CL_WARNING))
1583 {
1584 post_error ("?-W switch does not control warning", gnat_node);
1585 break;
1586 }
1587 else if (!(cl_options[option_index].flags & lang_mask))
1588 {
1589 post_error ("?-W switch not valid for Ada", gnat_node);
1590 break;
1591 }
1592 if (cl_options[option_index].flags & CL_JOINED)
1593 arg = option_string + 1 + cl_options[option_index].opt_len;
1594 }
1595 else
1596 option_index = 0;
1597
1598 set_default_handlers (&handlers, NULL);
1599 control_warning_option (option_index, (int) kind, arg, imply, location,
1600 lang_mask, &handlers, &global_options,
1601 &global_options_set, global_dc);
1602 }
1603 break;
1604
1605 default:
1606 break;
1607 }
1608
1609 return gnu_result;
1610 }
1611
1612 /* Check the inline status of nested function FNDECL wrt its parent function.
1613
1614 If a non-inline nested function is referenced from an inline external
1615 function, we cannot honor both requests at the same time without cloning
1616 the nested function in the current unit since it is private to its unit.
1617 We could inline it as well but it's probably better to err on the side
1618 of too little inlining.
1619
1620 This must be done only on nested functions present in the source code
1621 and not on nested functions generated by the compiler, e.g. finalizers,
1622 because they may be not marked inline and we don't want them to block
1623 the inlining of the parent function. */
1624
1625 static void
check_inlining_for_nested_subprog(tree fndecl)1626 check_inlining_for_nested_subprog (tree fndecl)
1627 {
1628 if (DECL_IGNORED_P (current_function_decl) || DECL_IGNORED_P (fndecl))
1629 return;
1630
1631 if (DECL_DECLARED_INLINE_P (fndecl))
1632 return;
1633
1634 tree parent_decl = decl_function_context (fndecl);
1635 if (DECL_EXTERNAL (parent_decl) && DECL_DECLARED_INLINE_P (parent_decl))
1636 {
1637 const location_t loc1 = DECL_SOURCE_LOCATION (fndecl);
1638 const location_t loc2 = DECL_SOURCE_LOCATION (parent_decl);
1639
1640 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl)))
1641 {
1642 error_at (loc1, "subprogram %q+F not marked %<Inline_Always%>",
1643 fndecl);
1644 error_at (loc2, "parent subprogram cannot be inlined");
1645 }
1646 else
1647 {
1648 warning_at (loc1, OPT_Winline, "subprogram %q+F not marked %<Inline%>",
1649 fndecl);
1650 warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined");
1651 }
1652
1653 DECL_DECLARED_INLINE_P (parent_decl) = 0;
1654 DECL_UNINLINABLE (parent_decl) = 1;
1655 }
1656 }
1657
1658 /* Return an expression for the length of TYPE, an integral type, computed in
1659 RESULT_TYPE, another integral type.
1660
1661 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1662 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1663 which would only overflow in much rarer cases, for extremely large arrays
1664 we expect never to encounter in practice. Besides, the former computation
1665 required the use of potentially constraining signed arithmetics while the
1666 latter does not. Note that the comparison must be done in the original
1667 base index type in order to avoid any overflow during the conversion. */
1668
1669 static tree
get_type_length(tree type,tree result_type)1670 get_type_length (tree type, tree result_type)
1671 {
1672 tree comp_type = get_base_type (result_type);
1673 tree base_type = maybe_character_type (get_base_type (type));
1674 tree lb = convert (base_type, TYPE_MIN_VALUE (type));
1675 tree hb = convert (base_type, TYPE_MAX_VALUE (type));
1676 tree length
1677 = build_binary_op (PLUS_EXPR, comp_type,
1678 build_binary_op (MINUS_EXPR, comp_type,
1679 convert (comp_type, hb),
1680 convert (comp_type, lb)),
1681 build_int_cst (comp_type, 1));
1682 length
1683 = build_cond_expr (result_type,
1684 build_binary_op (GE_EXPR, boolean_type_node, hb, lb),
1685 convert (result_type, length),
1686 build_int_cst (result_type, 0));
1687 return length;
1688 }
1689
1690 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1691 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1692 where we should place the result type. ATTRIBUTE is the attribute ID. */
1693
1694 static tree
Attribute_to_gnu(Node_Id gnat_node,tree * gnu_result_type_p,int attribute)1695 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1696 {
1697 const Node_Id gnat_prefix = Prefix (gnat_node);
1698 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
1699 tree gnu_type = TREE_TYPE (gnu_prefix);
1700 tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1701 bool prefix_unused = false;
1702
1703 /* If the input is a NULL_EXPR, make a new one. */
1704 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1705 {
1706 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1707 *gnu_result_type_p = gnu_result_type;
1708 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1709 }
1710
1711 switch (attribute)
1712 {
1713 case Attr_Pred:
1714 case Attr_Succ:
1715 /* These just add or subtract the constant 1 since representation
1716 clauses for enumeration types are handled in the front-end. */
1717 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1718 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1719 gnu_type = maybe_character_type (gnu_result_type);
1720 if (TREE_TYPE (gnu_expr) != gnu_type)
1721 gnu_expr = convert (gnu_type, gnu_expr);
1722 gnu_result
1723 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1724 gnu_type, gnu_expr, build_int_cst (gnu_type, 1));
1725 break;
1726
1727 case Attr_Address:
1728 case Attr_Unrestricted_Access:
1729 /* Conversions don't change the address of references but can cause
1730 build_unary_op to miss the references below, so strip them off.
1731 On the contrary, if the address-of operation causes a temporary
1732 to be created, then it must be created with the proper type. */
1733 gnu_expr = remove_conversions (gnu_prefix,
1734 !Must_Be_Byte_Aligned (gnat_node));
1735 if (REFERENCE_CLASS_P (gnu_expr))
1736 gnu_prefix = gnu_expr;
1737
1738 /* If we are taking 'Address of an unconstrained object, this is the
1739 pointer to the underlying array. */
1740 if (attribute == Attr_Address)
1741 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1742
1743 /* If we are building a static dispatch table, we have to honor
1744 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1745 with the C++ ABI. We do it in the non-static case as well,
1746 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1747 else if (TARGET_VTABLE_USES_DESCRIPTORS
1748 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1749 {
1750 tree gnu_field, t;
1751 /* Descriptors can only be built here for top-level functions. */
1752 bool build_descriptor = (global_bindings_p () != 0);
1753 int i;
1754 vec<constructor_elt, va_gc> *gnu_vec = NULL;
1755 constructor_elt *elt;
1756
1757 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1758
1759 /* If we're not going to build the descriptor, we have to retrieve
1760 the one which will be built by the linker (or by the compiler
1761 later if a static chain is requested). */
1762 if (!build_descriptor)
1763 {
1764 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1765 gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1766 gnu_result);
1767 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1768 }
1769
1770 vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS, true);
1771 elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1772 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1773 i < TARGET_VTABLE_USES_DESCRIPTORS;
1774 gnu_field = DECL_CHAIN (gnu_field), i++)
1775 {
1776 if (build_descriptor)
1777 {
1778 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1779 build_int_cst (NULL_TREE, i));
1780 TREE_CONSTANT (t) = 1;
1781 }
1782 else
1783 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1784 gnu_field, NULL_TREE);
1785
1786 elt->index = gnu_field;
1787 elt->value = t;
1788 elt--;
1789 }
1790
1791 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1792 break;
1793 }
1794
1795 /* ... fall through ... */
1796
1797 case Attr_Access:
1798 case Attr_Unchecked_Access:
1799 case Attr_Code_Address:
1800 /* Taking the address of a type does not make sense. */
1801 gcc_assert (TREE_CODE (gnu_prefix) != TYPE_DECL);
1802
1803 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1804 gnu_result
1805 = build_unary_op (((attribute == Attr_Address
1806 || attribute == Attr_Unrestricted_Access)
1807 && !Must_Be_Byte_Aligned (gnat_node))
1808 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1809 gnu_result_type, gnu_prefix);
1810
1811 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1812 don't try to build a trampoline. */
1813 if (attribute == Attr_Code_Address)
1814 {
1815 gnu_expr = remove_conversions (gnu_result, false);
1816
1817 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1818 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1819
1820 /* On targets for which function symbols denote a descriptor, the
1821 code address is stored within the first slot of the descriptor
1822 so we do an additional dereference:
1823 result = *((result_type *) result)
1824 where we expect result to be of some pointer type already. */
1825 if (targetm.calls.custom_function_descriptors == 0)
1826 gnu_result
1827 = build_unary_op (INDIRECT_REF, NULL_TREE,
1828 convert (build_pointer_type (gnu_result_type),
1829 gnu_result));
1830 }
1831
1832 /* For 'Access, issue an error message if the prefix is a C++ method
1833 since it can use a special calling convention on some platforms,
1834 which cannot be propagated to the access type. */
1835 else if (attribute == Attr_Access
1836 && TREE_CODE (TREE_TYPE (gnu_prefix)) == METHOD_TYPE)
1837 post_error ("access to C++ constructor or member function not allowed",
1838 gnat_node);
1839
1840 /* For other address attributes applied to a nested function,
1841 find an inner ADDR_EXPR and annotate it so that we can issue
1842 a useful warning with -Wtrampolines. */
1843 else if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_prefix))
1844 && (gnu_expr = remove_conversions (gnu_result, false))
1845 && TREE_CODE (gnu_expr) == ADDR_EXPR
1846 && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1847 {
1848 set_expr_location_from_node (gnu_expr, gnat_node);
1849
1850 /* Also check the inlining status. */
1851 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
1852
1853 /* Moreover, for 'Access or 'Unrestricted_Access with non-
1854 foreign-compatible representation, mark the ADDR_EXPR so
1855 that we can build a descriptor instead of a trampoline. */
1856 if ((attribute == Attr_Access
1857 || attribute == Attr_Unrestricted_Access)
1858 && targetm.calls.custom_function_descriptors > 0
1859 && Can_Use_Internal_Rep (Underlying_Type (Etype (gnat_node))))
1860 FUNC_ADDR_BY_DESCRIPTOR (gnu_expr) = 1;
1861
1862 /* Otherwise, we need to check that we are not violating the
1863 No_Implicit_Dynamic_Code restriction. */
1864 else if (targetm.calls.custom_function_descriptors != 0)
1865 Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1866 }
1867 break;
1868
1869 case Attr_Pool_Address:
1870 {
1871 tree gnu_ptr = gnu_prefix;
1872 tree gnu_obj_type;
1873
1874 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1875
1876 /* If this is fat pointer, the object must have been allocated with the
1877 template in front of the array. So compute the template address; do
1878 it by converting to a thin pointer. */
1879 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1880 gnu_ptr
1881 = convert (build_pointer_type
1882 (TYPE_OBJECT_RECORD_TYPE
1883 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1884 gnu_ptr);
1885
1886 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1887
1888 /* If this is a thin pointer, the object must have been allocated with
1889 the template in front of the array. So compute the template address
1890 and return it. */
1891 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
1892 gnu_ptr
1893 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
1894 gnu_ptr,
1895 fold_build1 (NEGATE_EXPR, sizetype,
1896 byte_position
1897 (DECL_CHAIN
1898 TYPE_FIELDS ((gnu_obj_type)))));
1899
1900 gnu_result = convert (gnu_result_type, gnu_ptr);
1901 }
1902 break;
1903
1904 case Attr_Size:
1905 case Attr_Object_Size:
1906 case Attr_Value_Size:
1907 case Attr_Max_Size_In_Storage_Elements:
1908 /* Strip NOPs, conversions between original and packable versions, and
1909 unpadding from GNU_PREFIX. Note that we cannot simply strip every
1910 VIEW_CONVERT_EXPR because some of them may give the actual size, e.g.
1911 for nominally unconstrained packed array. We use GNU_EXPR to see
1912 if a COMPONENT_REF was involved. */
1913 while (CONVERT_EXPR_P (gnu_prefix)
1914 || TREE_CODE (gnu_prefix) == NON_LVALUE_EXPR
1915 || (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
1916 && TREE_CODE (TREE_TYPE (gnu_prefix)) == RECORD_TYPE
1917 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1918 == RECORD_TYPE
1919 && TYPE_NAME (TREE_TYPE (gnu_prefix))
1920 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1921 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1922 gnu_expr = gnu_prefix;
1923 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1924 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1925 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1926 prefix_unused = true;
1927 gnu_type = TREE_TYPE (gnu_prefix);
1928
1929 /* Replace an unconstrained array type with the type of the underlying
1930 array, except for 'Max_Size_In_Storage_Elements because we need to
1931 return the (maximum) size requested for an allocator. */
1932 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1933 {
1934 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1935 if (attribute != Attr_Max_Size_In_Storage_Elements)
1936 gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1937 }
1938
1939 /* The type must be frozen at this point. */
1940 gcc_assert (COMPLETE_TYPE_P (gnu_type));
1941
1942 /* If we're looking for the size of a field, return the field size. */
1943 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1944 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1945
1946 /* Otherwise, if the prefix is an object, or if we are looking for
1947 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1948 GCC size of the type. We make an exception for padded objects,
1949 as we do not take into account alignment promotions for the size.
1950 This is in keeping with the object case of gnat_to_gnu_entity. */
1951 else if ((TREE_CODE (gnu_prefix) != TYPE_DECL
1952 && !(TYPE_IS_PADDING_P (gnu_type)
1953 && TREE_CODE (gnu_expr) == COMPONENT_REF
1954 && pad_type_has_rm_size (gnu_type)))
1955 || attribute == Attr_Object_Size
1956 || attribute == Attr_Max_Size_In_Storage_Elements)
1957 {
1958 /* If this is a dereference and we have a special dynamic constrained
1959 subtype on the prefix, use it to compute the size; otherwise, use
1960 the designated subtype. */
1961 if (Nkind (gnat_prefix) == N_Explicit_Dereference)
1962 {
1963 Node_Id gnat_actual_subtype
1964 = Actual_Designated_Subtype (gnat_prefix);
1965 tree gnu_ptr_type
1966 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
1967
1968 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1969 && Present (gnat_actual_subtype))
1970 {
1971 tree gnu_actual_obj_type
1972 = gnat_to_gnu_type (gnat_actual_subtype);
1973 gnu_type
1974 = build_unc_object_type_from_ptr (gnu_ptr_type,
1975 gnu_actual_obj_type,
1976 get_identifier ("SIZE"),
1977 false);
1978 }
1979 }
1980
1981 gnu_result = TYPE_SIZE (gnu_type);
1982 }
1983
1984 /* Otherwise, the result is the RM size of the type. */
1985 else
1986 gnu_result = rm_size (gnu_type);
1987
1988 /* Deal with a self-referential size by qualifying the size with the
1989 object or returning the maximum size for a type. */
1990 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1991 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1992 else if (CONTAINS_PLACEHOLDER_P (gnu_result))
1993 gnu_result = max_size (gnu_result, true);
1994
1995 /* If the type contains a template, subtract the padded size of the
1996 template, except for 'Max_Size_In_Storage_Elements because we need
1997 to return the (maximum) size requested for an allocator. */
1998 if (TREE_CODE (gnu_type) == RECORD_TYPE
1999 && TYPE_CONTAINS_TEMPLATE_P (gnu_type)
2000 && attribute != Attr_Max_Size_In_Storage_Elements)
2001 gnu_result
2002 = size_binop (MINUS_EXPR, gnu_result,
2003 bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
2004
2005 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
2006 if (attribute == Attr_Max_Size_In_Storage_Elements)
2007 gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
2008
2009 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2010 break;
2011
2012 case Attr_Alignment:
2013 {
2014 unsigned int align;
2015
2016 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
2017 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
2018 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
2019
2020 gnu_type = TREE_TYPE (gnu_prefix);
2021 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2022 prefix_unused = true;
2023
2024 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2025 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
2026 else
2027 {
2028 Entity_Id gnat_type = Etype (gnat_prefix);
2029 unsigned int double_align;
2030 bool is_capped_double, align_clause;
2031
2032 /* If the default alignment of "double" or larger scalar types is
2033 specifically capped and there is an alignment clause neither
2034 on the type nor on the prefix itself, return the cap. */
2035 if ((double_align = double_float_alignment) > 0)
2036 is_capped_double
2037 = is_double_float_or_array (gnat_type, &align_clause);
2038 else if ((double_align = double_scalar_alignment) > 0)
2039 is_capped_double
2040 = is_double_scalar_or_array (gnat_type, &align_clause);
2041 else
2042 is_capped_double = align_clause = false;
2043
2044 if (is_capped_double
2045 && Nkind (gnat_prefix) == N_Identifier
2046 && Present (Alignment_Clause (Entity (gnat_prefix))))
2047 align_clause = true;
2048
2049 if (is_capped_double && !align_clause)
2050 align = double_align;
2051 else
2052 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
2053 }
2054
2055 gnu_result = size_int (align);
2056 }
2057 break;
2058
2059 case Attr_First:
2060 case Attr_Last:
2061 case Attr_Range_Length:
2062 prefix_unused = true;
2063
2064 if (INTEGRAL_TYPE_P (gnu_type) || SCALAR_FLOAT_TYPE_P (gnu_type))
2065 {
2066 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2067
2068 if (attribute == Attr_First)
2069 gnu_result = TYPE_MIN_VALUE (gnu_type);
2070 else if (attribute == Attr_Last)
2071 gnu_result = TYPE_MAX_VALUE (gnu_type);
2072 else
2073 gnu_result = get_type_length (gnu_type, gnu_result_type);
2074 break;
2075 }
2076
2077 /* ... fall through ... */
2078
2079 case Attr_Length:
2080 {
2081 int Dimension = (Present (Expressions (gnat_node))
2082 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
2083 : 1), i;
2084 struct parm_attr_d *pa = NULL;
2085 Entity_Id gnat_param = Empty;
2086 bool unconstrained_ptr_deref = false;
2087
2088 gnu_prefix = maybe_padded_object (gnu_prefix);
2089 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
2090
2091 /* We treat unconstrained array In parameters specially. We also note
2092 whether we are dereferencing a pointer to unconstrained array. */
2093 if (!Is_Constrained (Etype (gnat_prefix)))
2094 switch (Nkind (gnat_prefix))
2095 {
2096 case N_Identifier:
2097 /* This is the direct case. */
2098 if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
2099 gnat_param = Entity (gnat_prefix);
2100 break;
2101
2102 case N_Explicit_Dereference:
2103 /* This is the indirect case. Note that we need to be sure that
2104 the access value cannot be null as we'll hoist the load. */
2105 if (Nkind (Prefix (gnat_prefix)) == N_Identifier
2106 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
2107 {
2108 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
2109 gnat_param = Entity (Prefix (gnat_prefix));
2110 }
2111 else
2112 unconstrained_ptr_deref = true;
2113 break;
2114
2115 default:
2116 break;
2117 }
2118
2119 /* If the prefix is the view conversion of a constrained array to an
2120 unconstrained form, we retrieve the constrained array because we
2121 might not be able to substitute the PLACEHOLDER_EXPR coming from
2122 the conversion. This can occur with the 'Old attribute applied
2123 to a parameter with an unconstrained type, which gets rewritten
2124 into a constrained local variable very late in the game. */
2125 if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
2126 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix)))
2127 && !CONTAINS_PLACEHOLDER_P
2128 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
2129 gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0));
2130 else
2131 gnu_type = TREE_TYPE (gnu_prefix);
2132
2133 prefix_unused = true;
2134 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2135
2136 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
2137 {
2138 int ndim;
2139 tree gnu_type_temp;
2140
2141 for (ndim = 1, gnu_type_temp = gnu_type;
2142 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
2143 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
2144 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
2145 ;
2146
2147 Dimension = ndim + 1 - Dimension;
2148 }
2149
2150 for (i = 1; i < Dimension; i++)
2151 gnu_type = TREE_TYPE (gnu_type);
2152
2153 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2154
2155 /* When not optimizing, look up the slot associated with the parameter
2156 and the dimension in the cache and create a new one on failure.
2157 Don't do this when the actual subtype needs debug info (this happens
2158 with -gnatD): in elaborate_expression_1, we create variables that
2159 hold the bounds, so caching attributes isn't very interesting and
2160 causes dependency issues between these variables and cached
2161 expressions. */
2162 if (!optimize
2163 && Present (gnat_param)
2164 && !(Present (Actual_Subtype (gnat_param))
2165 && Needs_Debug_Info (Actual_Subtype (gnat_param))))
2166 {
2167 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa)
2168 if (pa->id == gnat_param && pa->dim == Dimension)
2169 break;
2170
2171 if (!pa)
2172 {
2173 pa = ggc_cleared_alloc<parm_attr_d> ();
2174 pa->id = gnat_param;
2175 pa->dim = Dimension;
2176 vec_safe_push (f_parm_attr_cache, pa);
2177 }
2178 }
2179
2180 /* Return the cached expression or build a new one. */
2181 if (attribute == Attr_First)
2182 {
2183 if (pa && pa->first)
2184 {
2185 gnu_result = pa->first;
2186 break;
2187 }
2188
2189 gnu_result
2190 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2191 }
2192
2193 else if (attribute == Attr_Last)
2194 {
2195 if (pa && pa->last)
2196 {
2197 gnu_result = pa->last;
2198 break;
2199 }
2200
2201 gnu_result
2202 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2203 }
2204
2205 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2206 {
2207 if (pa && pa->length)
2208 {
2209 gnu_result = pa->length;
2210 break;
2211 }
2212
2213 gnu_result
2214 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)),
2215 gnu_result_type);
2216 }
2217
2218 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2219 handling. Note that these attributes could not have been used on
2220 an unconstrained array type. */
2221 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2222
2223 /* Cache the expression we have just computed. Since we want to do it
2224 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2225 create the temporary in the outermost binding level. We will make
2226 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2227 paths by forcing its evaluation on entry of the function. */
2228 if (pa)
2229 {
2230 gnu_result
2231 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2232 switch (attribute)
2233 {
2234 case Attr_First:
2235 pa->first = gnu_result;
2236 break;
2237
2238 case Attr_Last:
2239 pa->last = gnu_result;
2240 break;
2241
2242 case Attr_Length:
2243 case Attr_Range_Length:
2244 pa->length = gnu_result;
2245 break;
2246
2247 default:
2248 gcc_unreachable ();
2249 }
2250 }
2251
2252 /* Otherwise, evaluate it each time it is referenced. */
2253 else
2254 switch (attribute)
2255 {
2256 case Attr_First:
2257 case Attr_Last:
2258 /* If we are dereferencing a pointer to unconstrained array, we
2259 need to capture the value because the pointed-to bounds may
2260 subsequently be released. */
2261 if (unconstrained_ptr_deref)
2262 gnu_result
2263 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2264 break;
2265
2266 case Attr_Length:
2267 case Attr_Range_Length:
2268 /* Set the source location onto the predicate of the condition
2269 but not if the expression is cached to avoid messing up the
2270 debug info. */
2271 if (TREE_CODE (gnu_result) == COND_EXPR
2272 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
2273 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
2274 gnat_node);
2275 break;
2276
2277 default:
2278 gcc_unreachable ();
2279 }
2280
2281 break;
2282 }
2283
2284 case Attr_Bit_Position:
2285 case Attr_Position:
2286 case Attr_First_Bit:
2287 case Attr_Last_Bit:
2288 case Attr_Bit:
2289 {
2290 poly_int64 bitsize;
2291 poly_int64 bitpos;
2292 tree gnu_offset;
2293 tree gnu_field_bitpos;
2294 tree gnu_field_offset;
2295 tree gnu_inner;
2296 machine_mode mode;
2297 int unsignedp, reversep, volatilep;
2298
2299 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2300 gnu_prefix = remove_conversions (gnu_prefix, true);
2301 prefix_unused = true;
2302
2303 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2304 the result is 0. Don't allow 'Bit on a bare component, though. */
2305 if (attribute == Attr_Bit
2306 && TREE_CODE (gnu_prefix) != COMPONENT_REF
2307 && TREE_CODE (gnu_prefix) != FIELD_DECL)
2308 {
2309 gnu_result = integer_zero_node;
2310 break;
2311 }
2312
2313 else
2314 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
2315 || (attribute == Attr_Bit_Position
2316 && TREE_CODE (gnu_prefix) == FIELD_DECL));
2317
2318 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
2319 &mode, &unsignedp, &reversep, &volatilep);
2320
2321 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2322 {
2323 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
2324 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
2325
2326 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
2327 TREE_CODE (gnu_inner) == COMPONENT_REF
2328 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
2329 gnu_inner = TREE_OPERAND (gnu_inner, 0))
2330 {
2331 gnu_field_bitpos
2332 = size_binop (PLUS_EXPR, gnu_field_bitpos,
2333 bit_position (TREE_OPERAND (gnu_inner, 1)));
2334 gnu_field_offset
2335 = size_binop (PLUS_EXPR, gnu_field_offset,
2336 byte_position (TREE_OPERAND (gnu_inner, 1)));
2337 }
2338 }
2339 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
2340 {
2341 gnu_field_bitpos = bit_position (gnu_prefix);
2342 gnu_field_offset = byte_position (gnu_prefix);
2343 }
2344 else
2345 {
2346 gnu_field_bitpos = bitsize_zero_node;
2347 gnu_field_offset = size_zero_node;
2348 }
2349
2350 switch (attribute)
2351 {
2352 case Attr_Position:
2353 gnu_result = gnu_field_offset;
2354 break;
2355
2356 case Attr_First_Bit:
2357 case Attr_Bit:
2358 gnu_result = size_int (num_trailing_bits (bitpos));
2359 break;
2360
2361 case Attr_Last_Bit:
2362 gnu_result = bitsize_int (num_trailing_bits (bitpos));
2363 gnu_result = size_binop (PLUS_EXPR, gnu_result,
2364 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
2365 /* ??? Avoid a large unsigned result that will overflow when
2366 converted to the signed universal_integer. */
2367 if (integer_zerop (gnu_result))
2368 gnu_result = integer_minus_one_node;
2369 else
2370 gnu_result
2371 = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node);
2372 break;
2373
2374 case Attr_Bit_Position:
2375 gnu_result = gnu_field_bitpos;
2376 break;
2377 }
2378
2379 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2380 handling. */
2381 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2382 break;
2383 }
2384
2385 case Attr_Min:
2386 case Attr_Max:
2387 {
2388 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
2389 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
2390
2391 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2392
2393 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2394 a NaN so we implement the semantics of C99 f{min,max} to make it
2395 predictable in this case: if either operand is a NaN, the other
2396 is returned; if both operands are NaN's, a NaN is returned. */
2397 if (SCALAR_FLOAT_TYPE_P (gnu_result_type)
2398 && !Machine_Overflows_On_Target)
2399 {
2400 const bool lhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_lhs);
2401 const bool rhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_rhs);
2402 tree t = builtin_decl_explicit (BUILT_IN_ISNAN);
2403 tree lhs_is_nan, rhs_is_nan;
2404
2405 /* If the operands have side-effects, they need to be evaluated
2406 only once in spite of the multiple references in the result. */
2407 if (lhs_side_effects_p)
2408 gnu_lhs = gnat_protect_expr (gnu_lhs);
2409 if (rhs_side_effects_p)
2410 gnu_rhs = gnat_protect_expr (gnu_rhs);
2411
2412 lhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2413 build_call_expr (t, 1, gnu_lhs),
2414 integer_zero_node);
2415
2416 rhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2417 build_call_expr (t, 1, gnu_rhs),
2418 integer_zero_node);
2419
2420 gnu_result = build_binary_op (attribute == Attr_Min
2421 ? MIN_EXPR : MAX_EXPR,
2422 gnu_result_type, gnu_lhs, gnu_rhs);
2423 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2424 rhs_is_nan, gnu_lhs, gnu_result);
2425 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2426 lhs_is_nan, gnu_rhs, gnu_result);
2427
2428 /* If the operands have side-effects, they need to be evaluated
2429 before doing the tests above since the place they otherwise
2430 would end up being evaluated at run time could be wrong. */
2431 if (lhs_side_effects_p)
2432 gnu_result
2433 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_lhs, gnu_result);
2434
2435 if (rhs_side_effects_p)
2436 gnu_result
2437 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_rhs, gnu_result);
2438 }
2439 else
2440 gnu_result = build_binary_op (attribute == Attr_Min
2441 ? MIN_EXPR : MAX_EXPR,
2442 gnu_result_type, gnu_lhs, gnu_rhs);
2443 }
2444 break;
2445
2446 case Attr_Passed_By_Reference:
2447 gnu_result = size_int (default_pass_by_ref (gnu_type)
2448 || must_pass_by_ref (gnu_type));
2449 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2450 break;
2451
2452 case Attr_Component_Size:
2453 gnu_prefix = maybe_padded_object (gnu_prefix);
2454 gnu_type = TREE_TYPE (gnu_prefix);
2455
2456 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2457 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
2458
2459 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2460 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
2461 gnu_type = TREE_TYPE (gnu_type);
2462
2463 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2464
2465 /* Note this size cannot be self-referential. */
2466 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
2467 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2468 prefix_unused = true;
2469 break;
2470
2471 case Attr_Descriptor_Size:
2472 gnu_type = TREE_TYPE (gnu_prefix);
2473 gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
2474
2475 /* Return the padded size of the template in the object record type. */
2476 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
2477 gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
2478 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2479 prefix_unused = true;
2480 break;
2481
2482 case Attr_Null_Parameter:
2483 /* This is just a zero cast to the pointer type for our prefix and
2484 dereferenced. */
2485 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2486 gnu_result
2487 = build_unary_op (INDIRECT_REF, NULL_TREE,
2488 convert (build_pointer_type (gnu_result_type),
2489 integer_zero_node));
2490 break;
2491
2492 case Attr_Mechanism_Code:
2493 {
2494 Entity_Id gnat_obj = Entity (gnat_prefix);
2495 int code;
2496
2497 prefix_unused = true;
2498 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2499 if (Present (Expressions (gnat_node)))
2500 {
2501 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
2502
2503 for (gnat_obj = First_Formal (gnat_obj); i > 1;
2504 i--, gnat_obj = Next_Formal (gnat_obj))
2505 ;
2506 }
2507
2508 code = Mechanism (gnat_obj);
2509 if (code == Default)
2510 code = ((present_gnu_tree (gnat_obj)
2511 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
2512 || ((TREE_CODE (get_gnu_tree (gnat_obj))
2513 == PARM_DECL)
2514 && (DECL_BY_COMPONENT_PTR_P
2515 (get_gnu_tree (gnat_obj))))))
2516 ? By_Reference : By_Copy);
2517 gnu_result = convert (gnu_result_type, size_int (- code));
2518 }
2519 break;
2520
2521 case Attr_Model:
2522 /* We treat Model as identical to Machine. This is true for at least
2523 IEEE and some other nice floating-point systems. */
2524
2525 /* ... fall through ... */
2526
2527 case Attr_Machine:
2528 /* The trick is to force the compiler to store the result in memory so
2529 that we do not have extra precision used. But do this only when this
2530 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2531 the type is lower than that of the longest floating-point type. */
2532 prefix_unused = true;
2533 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2534 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2535 gnu_result = convert (gnu_result_type, gnu_expr);
2536
2537 if (TREE_CODE (gnu_result) != REAL_CST
2538 && fp_arith_may_widen
2539 && TYPE_PRECISION (gnu_result_type)
2540 < TYPE_PRECISION (longest_float_type_node))
2541 {
2542 tree rec_type = make_node (RECORD_TYPE);
2543 tree field
2544 = create_field_decl (get_identifier ("OBJ"), gnu_result_type,
2545 rec_type, NULL_TREE, NULL_TREE, 0, 0);
2546 tree rec_val, asm_expr;
2547
2548 finish_record_type (rec_type, field, 0, false);
2549
2550 rec_val = build_constructor_single (rec_type, field, gnu_result);
2551 rec_val = build1 (SAVE_EXPR, rec_type, rec_val);
2552
2553 asm_expr
2554 = build5 (ASM_EXPR, void_type_node,
2555 build_string (0, ""),
2556 tree_cons (build_tree_list (NULL_TREE,
2557 build_string (2, "=m")),
2558 rec_val, NULL_TREE),
2559 tree_cons (build_tree_list (NULL_TREE,
2560 build_string (1, "m")),
2561 rec_val, NULL_TREE),
2562 NULL_TREE, NULL_TREE);
2563 ASM_VOLATILE_P (asm_expr) = 1;
2564
2565 gnu_result
2566 = build_compound_expr (gnu_result_type, asm_expr,
2567 build_component_ref (rec_val, field,
2568 false));
2569 }
2570 break;
2571
2572 case Attr_Deref:
2573 prefix_unused = true;
2574 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2575 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2576 /* This can be a random address so build an alias-all pointer type. */
2577 gnu_expr
2578 = convert (build_pointer_type_for_mode (gnu_result_type, ptr_mode,
2579 true),
2580 gnu_expr);
2581 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_expr);
2582 break;
2583
2584 default:
2585 /* This abort means that we have an unimplemented attribute. */
2586 gcc_unreachable ();
2587 }
2588
2589 /* If this is an attribute where the prefix was unused, force a use of it if
2590 it has a side-effect. But don't do it if the prefix is just an entity
2591 name. However, if an access check is needed, we must do it. See second
2592 example in AARM 11.6(5.e). */
2593 if (prefix_unused
2594 && TREE_SIDE_EFFECTS (gnu_prefix)
2595 && !Is_Entity_Name (gnat_prefix))
2596 gnu_result
2597 = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
2598
2599 *gnu_result_type_p = gnu_result_type;
2600 return gnu_result;
2601 }
2602
2603 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2604 to a GCC tree, which is returned. */
2605
2606 static tree
Case_Statement_to_gnu(Node_Id gnat_node)2607 Case_Statement_to_gnu (Node_Id gnat_node)
2608 {
2609 tree gnu_result, gnu_expr, gnu_type, gnu_label;
2610 Node_Id gnat_when;
2611 location_t end_locus;
2612 bool may_fallthru = false;
2613
2614 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2615 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2616 gnu_expr = maybe_character_value (gnu_expr);
2617 gnu_type = TREE_TYPE (gnu_expr);
2618
2619 /* We build a SWITCH_EXPR that contains the code with interspersed
2620 CASE_LABEL_EXPRs for each label. */
2621 if (!Sloc_to_locus (End_Location (gnat_node), &end_locus))
2622 end_locus = input_location;
2623 gnu_label = create_artificial_label (end_locus);
2624 start_stmt_group ();
2625
2626 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2627 Present (gnat_when);
2628 gnat_when = Next_Non_Pragma (gnat_when))
2629 {
2630 bool choices_added_p = false;
2631 Node_Id gnat_choice;
2632
2633 /* First compile all the different case choices for the current WHEN
2634 alternative. */
2635 for (gnat_choice = First (Discrete_Choices (gnat_when));
2636 Present (gnat_choice);
2637 gnat_choice = Next (gnat_choice))
2638 {
2639 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2640 tree label = create_artificial_label (input_location);
2641
2642 switch (Nkind (gnat_choice))
2643 {
2644 case N_Range:
2645 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2646 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2647 break;
2648
2649 case N_Subtype_Indication:
2650 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2651 (Constraint (gnat_choice))));
2652 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2653 (Constraint (gnat_choice))));
2654 break;
2655
2656 case N_Identifier:
2657 case N_Expanded_Name:
2658 /* This represents either a subtype range or a static value of
2659 some kind; Ekind says which. */
2660 if (Is_Type (Entity (gnat_choice)))
2661 {
2662 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2663
2664 gnu_low = TYPE_MIN_VALUE (gnu_type);
2665 gnu_high = TYPE_MAX_VALUE (gnu_type);
2666 break;
2667 }
2668
2669 /* ... fall through ... */
2670
2671 case N_Character_Literal:
2672 case N_Integer_Literal:
2673 gnu_low = gnat_to_gnu (gnat_choice);
2674 break;
2675
2676 case N_Others_Choice:
2677 break;
2678
2679 default:
2680 gcc_unreachable ();
2681 }
2682
2683 /* Everything should be folded into constants at this point. */
2684 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
2685 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
2686
2687 if (gnu_low && TREE_TYPE (gnu_low) != gnu_type)
2688 gnu_low = convert (gnu_type, gnu_low);
2689 if (gnu_high && TREE_TYPE (gnu_high) != gnu_type)
2690 gnu_high = convert (gnu_type, gnu_high);
2691
2692 add_stmt_with_node (build_case_label (gnu_low, gnu_high, label),
2693 gnat_choice);
2694 choices_added_p = true;
2695 }
2696
2697 /* This construct doesn't define a scope so we shouldn't push a binding
2698 level around the statement list. Except that we have always done so
2699 historically and this makes it possible to reduce stack usage. As a
2700 compromise, we keep doing it for case statements, for which this has
2701 never been problematic, but not for case expressions in Ada 2012. */
2702 if (choices_added_p)
2703 {
2704 const bool is_case_expression
2705 = (Nkind (Parent (gnat_node)) == N_Expression_With_Actions);
2706 tree group
2707 = build_stmt_group (Statements (gnat_when), !is_case_expression);
2708 bool group_may_fallthru = block_may_fallthru (group);
2709 add_stmt (group);
2710 if (group_may_fallthru)
2711 {
2712 tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2713 SET_EXPR_LOCATION (stmt, end_locus);
2714 add_stmt (stmt);
2715 may_fallthru = true;
2716 }
2717 }
2718 }
2719
2720 /* Now emit a definition of the label the cases branch to, if any. */
2721 if (may_fallthru)
2722 add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2723 gnu_result = build2 (SWITCH_EXPR, gnu_type, gnu_expr, end_stmt_group ());
2724
2725 return gnu_result;
2726 }
2727
2728 /* Return true if we are in the body of a loop. */
2729
2730 static inline bool
inside_loop_p(void)2731 inside_loop_p (void)
2732 {
2733 return !vec_safe_is_empty (gnu_loop_stack);
2734 }
2735
2736 /* Find out whether EXPR is a simple additive expression based on the iteration
2737 variable of some enclosing loop in the current function. If so, return the
2738 loop and set *DISP to the displacement and *NEG_P to true if this is for a
2739 subtraction; otherwise, return NULL. */
2740
2741 static struct loop_info_d *
find_loop_for(tree expr,tree * disp,bool * neg_p)2742 find_loop_for (tree expr, tree *disp, bool *neg_p)
2743 {
2744 tree var, add, cst;
2745 bool minus_p;
2746 struct loop_info_d *iter = NULL;
2747 unsigned int i;
2748
2749 if (is_simple_additive_expression (expr, &add, &cst, &minus_p))
2750 {
2751 var = add;
2752 if (disp)
2753 *disp = cst;
2754 if (neg_p)
2755 *neg_p = minus_p;
2756 }
2757 else
2758 {
2759 var = expr;
2760 if (disp)
2761 *disp = NULL_TREE;
2762 if (neg_p)
2763 *neg_p = false;
2764 }
2765
2766 var = remove_conversions (var, false);
2767
2768 if (TREE_CODE (var) != VAR_DECL)
2769 return NULL;
2770
2771 if (decl_function_context (var) != current_function_decl)
2772 return NULL;
2773
2774 gcc_assert (vec_safe_length (gnu_loop_stack) > 0);
2775
2776 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
2777 if (var == iter->loop_var)
2778 break;
2779
2780 return iter;
2781 }
2782
2783 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2784 false, or the maximum value if MAX is true, of TYPE. */
2785
2786 static bool
can_equal_min_or_max_val_p(tree val,tree type,bool max)2787 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2788 {
2789 tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2790
2791 if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2792 return true;
2793
2794 if (TREE_CODE (val) == NOP_EXPR)
2795 val = (max
2796 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2797 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2798
2799 if (TREE_CODE (val) != INTEGER_CST)
2800 return true;
2801
2802 if (max)
2803 return tree_int_cst_lt (val, min_or_max_val) == 0;
2804 else
2805 return tree_int_cst_lt (min_or_max_val, val) == 0;
2806 }
2807
2808 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2809 If REVERSE is true, minimum value is taken as maximum value. */
2810
2811 static inline bool
can_equal_min_val_p(tree val,tree type,bool reverse)2812 can_equal_min_val_p (tree val, tree type, bool reverse)
2813 {
2814 return can_equal_min_or_max_val_p (val, type, reverse);
2815 }
2816
2817 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2818 If REVERSE is true, maximum value is taken as minimum value. */
2819
2820 static inline bool
can_equal_max_val_p(tree val,tree type,bool reverse)2821 can_equal_max_val_p (tree val, tree type, bool reverse)
2822 {
2823 return can_equal_min_or_max_val_p (val, type, !reverse);
2824 }
2825
2826 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
2827 true if both expressions have been replaced and false otherwise. */
2828
2829 static bool
make_invariant(tree * expr1,tree * expr2)2830 make_invariant (tree *expr1, tree *expr2)
2831 {
2832 tree inv_expr1 = gnat_invariant_expr (*expr1);
2833 tree inv_expr2 = gnat_invariant_expr (*expr2);
2834
2835 if (inv_expr1)
2836 *expr1 = inv_expr1;
2837
2838 if (inv_expr2)
2839 *expr2 = inv_expr2;
2840
2841 return inv_expr1 && inv_expr2;
2842 }
2843
2844 /* Helper function for walk_tree, used by independent_iterations_p below. */
2845
2846 static tree
scan_rhs_r(tree * tp,int * walk_subtrees,void * data)2847 scan_rhs_r (tree *tp, int *walk_subtrees, void *data)
2848 {
2849 bitmap *params = (bitmap *)data;
2850 tree t = *tp;
2851
2852 /* No need to walk into types or decls. */
2853 if (IS_TYPE_OR_DECL_P (t))
2854 *walk_subtrees = 0;
2855
2856 if (TREE_CODE (t) == PARM_DECL && bitmap_bit_p (*params, DECL_UID (t)))
2857 return t;
2858
2859 return NULL_TREE;
2860 }
2861
2862 /* Return true if STMT_LIST generates independent iterations in a loop. */
2863
2864 static bool
independent_iterations_p(tree stmt_list)2865 independent_iterations_p (tree stmt_list)
2866 {
2867 tree_stmt_iterator tsi;
2868 bitmap params = BITMAP_GGC_ALLOC();
2869 auto_vec<tree, 16> rhs;
2870 tree iter;
2871 int i;
2872
2873 if (TREE_CODE (stmt_list) == BIND_EXPR)
2874 stmt_list = BIND_EXPR_BODY (stmt_list);
2875
2876 /* Scan the list and return false on anything that is not either a check
2877 or an assignment to a parameter with restricted aliasing. */
2878 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
2879 {
2880 tree stmt = tsi_stmt (tsi);
2881
2882 switch (TREE_CODE (stmt))
2883 {
2884 case COND_EXPR:
2885 {
2886 if (COND_EXPR_ELSE (stmt))
2887 return false;
2888 if (TREE_CODE (COND_EXPR_THEN (stmt)) != CALL_EXPR)
2889 return false;
2890 tree func = get_callee_fndecl (COND_EXPR_THEN (stmt));
2891 if (!(func && TREE_THIS_VOLATILE (func)))
2892 return false;
2893 break;
2894 }
2895
2896 case MODIFY_EXPR:
2897 {
2898 tree lhs = TREE_OPERAND (stmt, 0);
2899 while (handled_component_p (lhs))
2900 lhs = TREE_OPERAND (lhs, 0);
2901 if (TREE_CODE (lhs) != INDIRECT_REF)
2902 return false;
2903 lhs = TREE_OPERAND (lhs, 0);
2904 if (!(TREE_CODE (lhs) == PARM_DECL
2905 && DECL_RESTRICTED_ALIASING_P (lhs)))
2906 return false;
2907 bitmap_set_bit (params, DECL_UID (lhs));
2908 rhs.safe_push (TREE_OPERAND (stmt, 1));
2909 break;
2910 }
2911
2912 default:
2913 return false;
2914 }
2915 }
2916
2917 /* At this point we know that the list contains only statements that will
2918 modify parameters with restricted aliasing. Check that the statements
2919 don't at the time read from these parameters. */
2920 FOR_EACH_VEC_ELT (rhs, i, iter)
2921 if (walk_tree_without_duplicates (&iter, scan_rhs_r, ¶ms))
2922 return false;
2923
2924 return true;
2925 }
2926
2927 /* Helper for Loop_Statement_to_gnu, to translate the body of a loop not
2928 subject to any sort of parallelization directive or restriction, designated
2929 by GNAT_NODE.
2930
2931 We expect the top of gnu_loop_stack to hold a pointer to the loop info
2932 setup for the translation, which holds a pointer to the initial gnu loop
2933 stmt node. We return the new gnu loop statement to use.
2934
2935 We might also set *GNU_COND_EXPR_P to request a variant of the translation
2936 scheme in Loop_Statement_to_gnu. */
2937
2938 static tree
Regular_Loop_to_gnu(Node_Id gnat_node,tree * gnu_cond_expr_p)2939 Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p)
2940 {
2941 const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2942 struct loop_info_d *const gnu_loop_info = gnu_loop_stack->last ();
2943 tree gnu_loop_stmt = gnu_loop_info->stmt;
2944 tree gnu_loop_label = LOOP_STMT_LABEL (gnu_loop_stmt);
2945 tree gnu_cond_expr = *gnu_cond_expr_p;
2946 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2947
2948 /* Set the condition under which the loop must keep going. If we have an
2949 explicit condition, use it to set the location information throughout
2950 the translation of the loop statement to avoid having multiple SLOCs.
2951
2952 For the case "LOOP .... END LOOP;" the condition is always true. */
2953 if (No (gnat_iter_scheme))
2954 ;
2955
2956 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2957 else if (Present (Condition (gnat_iter_scheme)))
2958 {
2959 LOOP_STMT_COND (gnu_loop_stmt)
2960 = gnat_to_gnu (Condition (gnat_iter_scheme));
2961
2962 set_expr_location_from_node (gnu_loop_stmt, gnat_iter_scheme);
2963 }
2964
2965 /* Otherwise we have an iteration scheme and the condition is given by the
2966 bounds of the subtype of the iteration variable. */
2967 else
2968 {
2969 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2970 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2971 Entity_Id gnat_type = Etype (gnat_loop_var);
2972 tree gnu_type = get_unpadded_type (gnat_type);
2973 tree gnu_base_type = maybe_character_type (get_base_type (gnu_type));
2974 tree gnu_one_node = build_int_cst (gnu_base_type, 1);
2975 tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2976 enum tree_code update_code, test_code, shift_code;
2977 bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2978
2979 gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type));
2980 gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type));
2981
2982 /* We must disable modulo reduction for the iteration variable, if any,
2983 in order for the loop comparison to be effective. */
2984 if (reverse)
2985 {
2986 gnu_first = gnu_high;
2987 gnu_last = gnu_low;
2988 update_code = MINUS_NOMOD_EXPR;
2989 test_code = GE_EXPR;
2990 shift_code = PLUS_NOMOD_EXPR;
2991 }
2992 else
2993 {
2994 gnu_first = gnu_low;
2995 gnu_last = gnu_high;
2996 update_code = PLUS_NOMOD_EXPR;
2997 test_code = LE_EXPR;
2998 shift_code = MINUS_NOMOD_EXPR;
2999 }
3000
3001 /* We use two different strategies to translate the loop, depending on
3002 whether optimization is enabled.
3003
3004 If it is, we generate the canonical loop form expected by the loop
3005 optimizer and the loop vectorizer, which is the do-while form:
3006
3007 ENTRY_COND
3008 loop:
3009 TOP_UPDATE
3010 BODY
3011 BOTTOM_COND
3012 GOTO loop
3013
3014 This avoids an implicit dependency on loop header copying and makes
3015 it possible to turn BOTTOM_COND into an inequality test.
3016
3017 If optimization is disabled, loop header copying doesn't come into
3018 play and we try to generate the loop form with the fewer conditional
3019 branches. First, the default form, which is:
3020
3021 loop:
3022 TOP_COND
3023 BODY
3024 BOTTOM_UPDATE
3025 GOTO loop
3026
3027 It should catch most loops with constant ending point. Then, if we
3028 cannot, we try to generate the shifted form:
3029
3030 loop:
3031 TOP_COND
3032 TOP_UPDATE
3033 BODY
3034 GOTO loop
3035
3036 which should catch loops with constant starting point. Otherwise, if
3037 we cannot, we generate the fallback form:
3038
3039 ENTRY_COND
3040 loop:
3041 BODY
3042 BOTTOM_COND
3043 BOTTOM_UPDATE
3044 GOTO loop
3045
3046 which works in all cases. */
3047
3048 if (optimize && !optimize_debug)
3049 {
3050 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
3051 overflow. */
3052 if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
3053 ;
3054
3055 /* Otherwise, use the do-while form with the help of a special
3056 induction variable in the unsigned version of the base type
3057 or the unsigned version of the size type, whichever is the
3058 largest, in order to have wrap-around arithmetics for it. */
3059 else
3060 {
3061 if (TYPE_PRECISION (gnu_base_type)
3062 > TYPE_PRECISION (size_type_node))
3063 gnu_base_type
3064 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1);
3065 else
3066 gnu_base_type = size_type_node;
3067
3068 gnu_first = convert (gnu_base_type, gnu_first);
3069 gnu_last = convert (gnu_base_type, gnu_last);
3070 gnu_one_node = build_int_cst (gnu_base_type, 1);
3071 use_iv = true;
3072 }
3073
3074 gnu_first
3075 = build_binary_op (shift_code, gnu_base_type, gnu_first,
3076 gnu_one_node);
3077 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
3078 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3079 }
3080 else
3081 {
3082 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
3083 if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
3084 ;
3085
3086 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
3087 GNU_LAST-1 does. */
3088 else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
3089 && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
3090 {
3091 gnu_first
3092 = build_binary_op (shift_code, gnu_base_type, gnu_first,
3093 gnu_one_node);
3094 gnu_last
3095 = build_binary_op (shift_code, gnu_base_type, gnu_last,
3096 gnu_one_node);
3097 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
3098 }
3099
3100 /* Otherwise, use the fallback form. */
3101 else
3102 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3103 }
3104
3105 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3106 test but we have to add ENTRY_COND to protect the empty loop. */
3107 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
3108 {
3109 test_code = NE_EXPR;
3110 gnu_cond_expr
3111 = build3 (COND_EXPR, void_type_node,
3112 build_binary_op (LE_EXPR, boolean_type_node,
3113 gnu_low, gnu_high),
3114 NULL_TREE, alloc_stmt_list ());
3115 set_expr_location_from_node (gnu_cond_expr, gnat_iter_scheme);
3116 }
3117
3118 /* Open a new nesting level that will surround the loop to declare the
3119 iteration variable. */
3120 start_stmt_group ();
3121 gnat_pushlevel ();
3122
3123 /* If we use the special induction variable, create it and set it to
3124 its initial value. Morever, the regular iteration variable cannot
3125 itself be initialized, lest the initial value wrapped around. */
3126 if (use_iv)
3127 {
3128 gnu_loop_iv
3129 = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
3130 add_stmt (gnu_stmt);
3131 gnu_first = NULL_TREE;
3132 }
3133 else
3134 gnu_loop_iv = NULL_TREE;
3135
3136 /* Declare the iteration variable and set it to its initial value. */
3137 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, true);
3138 if (DECL_BY_REF_P (gnu_loop_var))
3139 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
3140 else if (use_iv)
3141 {
3142 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
3143 SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
3144 }
3145 gnu_loop_info->loop_var = gnu_loop_var;
3146 gnu_loop_info->low_bound = gnu_low;
3147 gnu_loop_info->high_bound = gnu_high;
3148
3149 /* Do all the arithmetics in the base type. */
3150 gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
3151
3152 /* Set either the top or bottom exit condition. */
3153 if (use_iv)
3154 LOOP_STMT_COND (gnu_loop_stmt)
3155 = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
3156 gnu_last);
3157 else
3158 LOOP_STMT_COND (gnu_loop_stmt)
3159 = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
3160 gnu_last);
3161
3162 /* Set either the top or bottom update statement and give it the source
3163 location of the iteration for better coverage info. */
3164 if (use_iv)
3165 {
3166 gnu_stmt
3167 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
3168 build_binary_op (update_code, gnu_base_type,
3169 gnu_loop_iv, gnu_one_node));
3170 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3171 append_to_statement_list (gnu_stmt,
3172 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3173 gnu_stmt
3174 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3175 gnu_loop_iv);
3176 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3177 append_to_statement_list (gnu_stmt,
3178 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3179 }
3180 else
3181 {
3182 gnu_stmt
3183 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3184 build_binary_op (update_code, gnu_base_type,
3185 gnu_loop_var, gnu_one_node));
3186 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3187 LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
3188 }
3189
3190 set_expr_location_from_node (gnu_loop_stmt, gnat_iter_scheme);
3191 }
3192
3193 /* If the loop was named, have the name point to this loop. In this case,
3194 the association is not a DECL node, but the end label of the loop. */
3195 if (Present (Identifier (gnat_node)))
3196 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
3197
3198 /* Make the loop body into its own block, so any allocated storage will be
3199 released every iteration. This is needed for stack allocation. */
3200 LOOP_STMT_BODY (gnu_loop_stmt)
3201 = build_stmt_group (Statements (gnat_node), true);
3202 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
3203
3204 /* If we have an iteration scheme, then we are in a statement group. Add
3205 the LOOP_STMT to it, finish it and make it the "loop". */
3206 if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
3207 {
3208 /* First, if we have computed invariant conditions for range (or index)
3209 checks applied to the iteration variable, find out whether they can
3210 be evaluated to false at compile time; otherwise, if there are not
3211 too many of them, combine them with the original checks. If loop
3212 unswitching is enabled, do not require the loop bounds to be also
3213 invariant, as their evaluation will still be ahead of the loop. */
3214 if (vec_safe_length (gnu_loop_info->checks) > 0
3215 && (make_invariant (&gnu_low, &gnu_high) || optimize >= 3))
3216 {
3217 struct range_check_info_d *rci;
3218 unsigned int i, n_remaining_checks = 0;
3219
3220 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3221 {
3222 tree low_ok, high_ok;
3223
3224 if (rci->low_bound)
3225 {
3226 tree gnu_adjusted_low = convert (rci->type, gnu_low);
3227 if (rci->disp)
3228 gnu_adjusted_low
3229 = fold_build2 (rci->neg_p ? MINUS_EXPR : PLUS_EXPR,
3230 rci->type, gnu_adjusted_low, rci->disp);
3231 low_ok
3232 = build_binary_op (GE_EXPR, boolean_type_node,
3233 gnu_adjusted_low, rci->low_bound);
3234 }
3235 else
3236 low_ok = boolean_true_node;
3237
3238 if (rci->high_bound)
3239 {
3240 tree gnu_adjusted_high = convert (rci->type, gnu_high);
3241 if (rci->disp)
3242 gnu_adjusted_high
3243 = fold_build2 (rci->neg_p ? MINUS_EXPR : PLUS_EXPR,
3244 rci->type, gnu_adjusted_high, rci->disp);
3245 high_ok
3246 = build_binary_op (LE_EXPR, boolean_type_node,
3247 gnu_adjusted_high, rci->high_bound);
3248 }
3249 else
3250 high_ok = boolean_true_node;
3251
3252 tree range_ok
3253 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
3254 low_ok, high_ok);
3255
3256 rci->invariant_cond
3257 = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
3258
3259 if (rci->invariant_cond == boolean_false_node)
3260 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3261 else
3262 n_remaining_checks++;
3263 }
3264
3265 /* Note that loop unswitching can only be applied a small number of
3266 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3267 if (IN_RANGE (n_remaining_checks, 1, 3)
3268 && optimize >= 2
3269 && !optimize_size)
3270 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3271 if (rci->invariant_cond != boolean_false_node)
3272 {
3273 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3274
3275 if (optimize >= 3)
3276 add_stmt_with_node_force (rci->inserted_cond, gnat_node);
3277 }
3278 }
3279
3280 /* Second, if loop vectorization is enabled and the iterations of the
3281 loop can easily be proved as independent, mark the loop. */
3282 if (optimize >= 3
3283 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt)))
3284 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
3285
3286 add_stmt (gnu_loop_stmt);
3287 gnat_poplevel ();
3288 gnu_loop_stmt = end_stmt_group ();
3289 }
3290
3291 *gnu_cond_expr_p = gnu_cond_expr;
3292
3293 return gnu_loop_stmt;
3294 }
3295
3296 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
3297 to a GCC tree, which is returned. */
3298
3299 static tree
Loop_Statement_to_gnu(Node_Id gnat_node)3300 Loop_Statement_to_gnu (Node_Id gnat_node)
3301 {
3302 struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
3303
3304 tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
3305 NULL_TREE, NULL_TREE, NULL_TREE);
3306 tree gnu_cond_expr = NULL_TREE;
3307 tree gnu_loop_label = create_artificial_label (input_location);
3308 tree gnu_result;
3309
3310 /* Push the loop_info structure associated with the LOOP_STMT. */
3311 vec_safe_push (gnu_loop_stack, gnu_loop_info);
3312
3313 /* Set location information for statement and end label. */
3314 set_expr_location_from_node (gnu_loop_stmt, gnat_node);
3315 Sloc_to_locus (Sloc (End_Label (gnat_node)),
3316 &DECL_SOURCE_LOCATION (gnu_loop_label));
3317 LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
3318
3319 /* Save the statement for later reuse. */
3320 gnu_loop_info->stmt = gnu_loop_stmt;
3321
3322 /* Perform the core loop body translation. */
3323 gnu_loop_stmt = Regular_Loop_to_gnu (gnat_node, &gnu_cond_expr);
3324
3325 /* If we have an outer COND_EXPR, that's our result and this loop is its
3326 "true" statement. Otherwise, the result is the LOOP_STMT. */
3327 if (gnu_cond_expr)
3328 {
3329 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
3330 TREE_SIDE_EFFECTS (gnu_cond_expr) = 1;
3331 gnu_result = gnu_cond_expr;
3332 }
3333 else
3334 gnu_result = gnu_loop_stmt;
3335
3336 gnu_loop_stack->pop ();
3337
3338 return gnu_result;
3339 }
3340
3341 /* This page implements a form of Named Return Value optimization modeled
3342 on the C++ optimization of the same name. The main difference is that
3343 we disregard any semantical considerations when applying it here, the
3344 counterpart being that we don't try to apply it to semantically loaded
3345 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3346
3347 We consider a function body of the following GENERIC form:
3348
3349 return_type R1;
3350 [...]
3351 RETURN_EXPR [<retval> = ...]
3352 [...]
3353 RETURN_EXPR [<retval> = R1]
3354 [...]
3355 return_type Ri;
3356 [...]
3357 RETURN_EXPR [<retval> = ...]
3358 [...]
3359 RETURN_EXPR [<retval> = Ri]
3360 [...]
3361
3362 where the Ri are not addressable and we try to fulfill a simple criterion
3363 that would make it possible to replace one or several Ri variables by the
3364 single RESULT_DECL of the function.
3365
3366 The first observation is that RETURN_EXPRs that don't directly reference
3367 any of the Ri variables on the RHS of their assignment are transparent wrt
3368 the optimization. This is because the Ri variables aren't addressable so
3369 any transformation applied to them doesn't affect the RHS; moreover, the
3370 assignment writes the full <retval> object so existing values are entirely
3371 discarded.
3372
3373 This property can be extended to some forms of RETURN_EXPRs that reference
3374 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3375 case, in particular when function calls are involved.
3376
3377 Therefore the algorithm is as follows:
3378
3379 1. Collect the list of candidates for a Named Return Value (Ri variables
3380 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3381 other expressions on the RHS of such assignments.
3382
3383 2. Prune the members of the first list (candidates) that are referenced
3384 by a member of the second list (expressions).
3385
3386 3. Extract a set of candidates with non-overlapping live ranges from the
3387 first list. These are the Named Return Values.
3388
3389 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3390 Named Return Values in the function with the RESULT_DECL.
3391
3392 If the function returns an unconstrained type, things are a bit different
3393 because the anonymous return object is allocated on the secondary stack
3394 and RESULT_DECL is only a pointer to it. Each return object can be of a
3395 different size and is allocated separately so we need not care about the
3396 addressability and the aforementioned overlapping issues. Therefore, we
3397 don't collect the other expressions and skip step #2 in the algorithm. */
3398
3399 struct nrv_data
3400 {
3401 bitmap nrv;
3402 tree result;
3403 Node_Id gnat_ret;
3404 hash_set<tree> *visited;
3405 };
3406
3407 /* Return true if T is a Named Return Value. */
3408
3409 static inline bool
is_nrv_p(bitmap nrv,tree t)3410 is_nrv_p (bitmap nrv, tree t)
3411 {
3412 return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
3413 }
3414
3415 /* Helper function for walk_tree, used by finalize_nrv below. */
3416
3417 static tree
prune_nrv_r(tree * tp,int * walk_subtrees,void * data)3418 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
3419 {
3420 struct nrv_data *dp = (struct nrv_data *)data;
3421 tree t = *tp;
3422
3423 /* No need to walk into types or decls. */
3424 if (IS_TYPE_OR_DECL_P (t))
3425 *walk_subtrees = 0;
3426
3427 if (is_nrv_p (dp->nrv, t))
3428 bitmap_clear_bit (dp->nrv, DECL_UID (t));
3429
3430 return NULL_TREE;
3431 }
3432
3433 /* Prune Named Return Values in BLOCK and return true if there is still a
3434 Named Return Value in BLOCK or one of its sub-blocks. */
3435
3436 static bool
prune_nrv_in_block(bitmap nrv,tree block)3437 prune_nrv_in_block (bitmap nrv, tree block)
3438 {
3439 bool has_nrv = false;
3440 tree t;
3441
3442 /* First recurse on the sub-blocks. */
3443 for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
3444 has_nrv |= prune_nrv_in_block (nrv, t);
3445
3446 /* Then make sure to keep at most one NRV per block. */
3447 for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
3448 if (is_nrv_p (nrv, t))
3449 {
3450 if (has_nrv)
3451 bitmap_clear_bit (nrv, DECL_UID (t));
3452 else
3453 has_nrv = true;
3454 }
3455
3456 return has_nrv;
3457 }
3458
3459 /* Helper function for walk_tree, used by finalize_nrv below. */
3460
3461 static tree
finalize_nrv_r(tree * tp,int * walk_subtrees,void * data)3462 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
3463 {
3464 struct nrv_data *dp = (struct nrv_data *)data;
3465 tree t = *tp;
3466
3467 /* No need to walk into types. */
3468 if (TYPE_P (t))
3469 *walk_subtrees = 0;
3470
3471 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3472 nop, but differs from using NULL_TREE in that it indicates that we care
3473 about the value of the RESULT_DECL. */
3474 else if (TREE_CODE (t) == RETURN_EXPR
3475 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3476 {
3477 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3478
3479 /* Strip useless conversions around the return value. */
3480 if (gnat_useless_type_conversion (ret_val))
3481 ret_val = TREE_OPERAND (ret_val, 0);
3482
3483 if (is_nrv_p (dp->nrv, ret_val))
3484 TREE_OPERAND (t, 0) = dp->result;
3485 }
3486
3487 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3488 if needed. */
3489 else if (TREE_CODE (t) == DECL_EXPR
3490 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3491 {
3492 tree var = DECL_EXPR_DECL (t), init;
3493
3494 if (DECL_INITIAL (var))
3495 {
3496 init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
3497 DECL_INITIAL (var));
3498 SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
3499 DECL_INITIAL (var) = NULL_TREE;
3500 }
3501 else
3502 init = build_empty_stmt (EXPR_LOCATION (t));
3503 *tp = init;
3504
3505 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3506 SET_DECL_VALUE_EXPR (var, dp->result);
3507 DECL_HAS_VALUE_EXPR_P (var) = 1;
3508 /* ??? Kludge to avoid an assertion failure during inlining. */
3509 DECL_SIZE (var) = bitsize_unit_node;
3510 DECL_SIZE_UNIT (var) = size_one_node;
3511 }
3512
3513 /* And replace all uses of NRVs with the RESULT_DECL. */
3514 else if (is_nrv_p (dp->nrv, t))
3515 *tp = convert (TREE_TYPE (t), dp->result);
3516
3517 /* Avoid walking into the same tree more than once. Unfortunately, we
3518 can't just use walk_tree_without_duplicates because it would only
3519 call us for the first occurrence of NRVs in the function body. */
3520 if (dp->visited->add (*tp))
3521 *walk_subtrees = 0;
3522
3523 return NULL_TREE;
3524 }
3525
3526 /* Likewise, but used when the function returns an unconstrained type. */
3527
3528 static tree
finalize_nrv_unc_r(tree * tp,int * walk_subtrees,void * data)3529 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
3530 {
3531 struct nrv_data *dp = (struct nrv_data *)data;
3532 tree t = *tp;
3533
3534 /* No need to walk into types. */
3535 if (TYPE_P (t))
3536 *walk_subtrees = 0;
3537
3538 /* We need to see the DECL_EXPR of NRVs before any other references so we
3539 walk the body of BIND_EXPR before walking its variables. */
3540 else if (TREE_CODE (t) == BIND_EXPR)
3541 walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
3542
3543 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3544 return value built by the allocator instead of the whole construct. */
3545 else if (TREE_CODE (t) == RETURN_EXPR
3546 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3547 {
3548 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3549
3550 /* This is the construct returned by the allocator. */
3551 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3552 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
3553 {
3554 tree rhs = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3555
3556 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
3557 ret_val = CONSTRUCTOR_ELT (rhs, 1)->value;
3558 else
3559 ret_val = rhs;
3560 }
3561
3562 /* Strip useless conversions around the return value. */
3563 if (gnat_useless_type_conversion (ret_val)
3564 || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
3565 ret_val = TREE_OPERAND (ret_val, 0);
3566
3567 /* Strip unpadding around the return value. */
3568 if (TREE_CODE (ret_val) == COMPONENT_REF
3569 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
3570 ret_val = TREE_OPERAND (ret_val, 0);
3571
3572 /* Assign the new return value to the RESULT_DECL. */
3573 if (is_nrv_p (dp->nrv, ret_val))
3574 TREE_OPERAND (TREE_OPERAND (t, 0), 1)
3575 = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
3576 }
3577
3578 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3579 into a new variable. */
3580 else if (TREE_CODE (t) == DECL_EXPR
3581 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3582 {
3583 tree saved_current_function_decl = current_function_decl;
3584 tree var = DECL_EXPR_DECL (t);
3585 tree alloc, p_array, new_var, new_ret;
3586 vec<constructor_elt, va_gc> *v;
3587 vec_alloc (v, 2);
3588
3589 /* Create an artificial context to build the allocation. */
3590 current_function_decl = decl_function_context (var);
3591 start_stmt_group ();
3592 gnat_pushlevel ();
3593
3594 /* This will return a COMPOUND_EXPR with the allocation in the first
3595 arm and the final return value in the second arm. */
3596 alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
3597 TREE_TYPE (dp->result),
3598 Procedure_To_Call (dp->gnat_ret),
3599 Storage_Pool (dp->gnat_ret),
3600 Empty, false);
3601
3602 /* The new variable is built as a reference to the allocated space. */
3603 new_var
3604 = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
3605 build_reference_type (TREE_TYPE (var)));
3606 DECL_BY_REFERENCE (new_var) = 1;
3607
3608 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
3609 {
3610 tree cst = TREE_OPERAND (alloc, 1);
3611
3612 /* The new initial value is a COMPOUND_EXPR with the allocation in
3613 the first arm and the value of P_ARRAY in the second arm. */
3614 DECL_INITIAL (new_var)
3615 = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
3616 TREE_OPERAND (alloc, 0),
3617 CONSTRUCTOR_ELT (cst, 0)->value);
3618
3619 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3620 p_array = TYPE_FIELDS (TREE_TYPE (alloc));
3621 CONSTRUCTOR_APPEND_ELT (v, p_array,
3622 fold_convert (TREE_TYPE (p_array), new_var));
3623 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
3624 CONSTRUCTOR_ELT (cst, 1)->value);
3625 new_ret = build_constructor (TREE_TYPE (alloc), v);
3626 }
3627 else
3628 {
3629 /* The new initial value is just the allocation. */
3630 DECL_INITIAL (new_var) = alloc;
3631 new_ret = fold_convert (TREE_TYPE (alloc), new_var);
3632 }
3633
3634 gnat_pushdecl (new_var, Empty);
3635
3636 /* Destroy the artificial context and insert the new statements. */
3637 gnat_zaplevel ();
3638 *tp = end_stmt_group ();
3639 current_function_decl = saved_current_function_decl;
3640
3641 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3642 DECL_CHAIN (new_var) = DECL_CHAIN (var);
3643 DECL_CHAIN (var) = new_var;
3644 DECL_IGNORED_P (var) = 1;
3645
3646 /* Save the new return value and the dereference of NEW_VAR. */
3647 DECL_INITIAL (var)
3648 = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
3649 build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
3650 /* ??? Kludge to avoid messing up during inlining. */
3651 DECL_CONTEXT (var) = NULL_TREE;
3652 }
3653
3654 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3655 else if (is_nrv_p (dp->nrv, t))
3656 *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3657
3658 /* Avoid walking into the same tree more than once. Unfortunately, we
3659 can't just use walk_tree_without_duplicates because it would only
3660 call us for the first occurrence of NRVs in the function body. */
3661 if (dp->visited->add (*tp))
3662 *walk_subtrees = 0;
3663
3664 return NULL_TREE;
3665 }
3666
3667 /* Apply FUNC to all the sub-trees of nested functions in NODE. FUNC is called
3668 with the DATA and the address of each sub-tree. If FUNC returns a non-NULL
3669 value, the traversal is stopped. */
3670
3671 static void
walk_nesting_tree(struct cgraph_node * node,walk_tree_fn func,void * data)3672 walk_nesting_tree (struct cgraph_node *node, walk_tree_fn func, void *data)
3673 {
3674 for (node = first_nested_function (node);
3675 node; node = next_nested_function (node))
3676 {
3677 walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), func, data);
3678 walk_nesting_tree (node, func, data);
3679 }
3680 }
3681
3682 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3683 contains the candidates for Named Return Value and OTHER is a list of
3684 the other return values. GNAT_RET is a representative return node. */
3685
3686 static void
finalize_nrv(tree fndecl,bitmap nrv,vec<tree,va_gc> * other,Node_Id gnat_ret)3687 finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret)
3688 {
3689 struct nrv_data data;
3690 walk_tree_fn func;
3691 unsigned int i;
3692 tree iter;
3693
3694 /* We shouldn't be applying the optimization to return types that we aren't
3695 allowed to manipulate freely. */
3696 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3697
3698 /* Prune the candidates that are referenced by other return values. */
3699 data.nrv = nrv;
3700 data.result = NULL_TREE;
3701 data.gnat_ret = Empty;
3702 data.visited = NULL;
3703 FOR_EACH_VEC_SAFE_ELT (other, i, iter)
3704 walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3705 if (bitmap_empty_p (nrv))
3706 return;
3707
3708 /* Prune also the candidates that are referenced by nested functions. */
3709 walk_nesting_tree (cgraph_node::get_create (fndecl), prune_nrv_r, &data);
3710 if (bitmap_empty_p (nrv))
3711 return;
3712
3713 /* Extract a set of NRVs with non-overlapping live ranges. */
3714 if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3715 return;
3716
3717 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3718 data.nrv = nrv;
3719 data.result = DECL_RESULT (fndecl);
3720 data.gnat_ret = gnat_ret;
3721 data.visited = new hash_set<tree>;
3722 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3723 func = finalize_nrv_unc_r;
3724 else
3725 func = finalize_nrv_r;
3726 walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3727 delete data.visited;
3728 }
3729
3730 /* Return true if RET_VAL can be used as a Named Return Value for the
3731 anonymous return object RET_OBJ. */
3732
3733 static bool
return_value_ok_for_nrv_p(tree ret_obj,tree ret_val)3734 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3735 {
3736 if (TREE_CODE (ret_val) != VAR_DECL)
3737 return false;
3738
3739 if (TREE_THIS_VOLATILE (ret_val))
3740 return false;
3741
3742 if (DECL_CONTEXT (ret_val) != current_function_decl)
3743 return false;
3744
3745 if (TREE_STATIC (ret_val))
3746 return false;
3747
3748 /* For the constrained case, test for addressability. */
3749 if (ret_obj && TREE_ADDRESSABLE (ret_val))
3750 return false;
3751
3752 /* For the constrained case, test for overalignment. */
3753 if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3754 return false;
3755
3756 /* For the unconstrained case, test for bogus initialization. */
3757 if (!ret_obj
3758 && DECL_INITIAL (ret_val)
3759 && TREE_CODE (DECL_INITIAL (ret_val)) == NULL_EXPR)
3760 return false;
3761
3762 return true;
3763 }
3764
3765 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3766 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3767 around RESULT_OBJ, which may be null in this case. */
3768
3769 static tree
build_return_expr(tree ret_obj,tree ret_val)3770 build_return_expr (tree ret_obj, tree ret_val)
3771 {
3772 tree result_expr;
3773
3774 if (ret_val)
3775 {
3776 /* The gimplifier explicitly enforces the following invariant:
3777
3778 RETURN_EXPR
3779 |
3780 INIT_EXPR
3781 / \
3782 / \
3783 RET_OBJ ...
3784
3785 As a consequence, type consistency dictates that we use the type
3786 of the RET_OBJ as the operation type. */
3787 tree operation_type = TREE_TYPE (ret_obj);
3788
3789 /* Convert the right operand to the operation type. Note that this is
3790 the transformation applied in the INIT_EXPR case of build_binary_op,
3791 with the assumption that the type cannot involve a placeholder. */
3792 if (operation_type != TREE_TYPE (ret_val))
3793 ret_val = convert (operation_type, ret_val);
3794
3795 /* We always can use an INIT_EXPR for the return object. */
3796 result_expr = build2 (INIT_EXPR, void_type_node, ret_obj, ret_val);
3797
3798 /* If the function returns an aggregate type, find out whether this is
3799 a candidate for Named Return Value. If so, record it. Otherwise,
3800 if this is an expression of some kind, record it elsewhere. */
3801 if (optimize
3802 && !optimize_debug
3803 && AGGREGATE_TYPE_P (operation_type)
3804 && !TYPE_IS_FAT_POINTER_P (operation_type)
3805 && TYPE_MODE (operation_type) == BLKmode
3806 && aggregate_value_p (operation_type, current_function_decl))
3807 {
3808 /* Strip useless conversions around the return value. */
3809 if (gnat_useless_type_conversion (ret_val))
3810 ret_val = TREE_OPERAND (ret_val, 0);
3811
3812 /* Now apply the test to the return value. */
3813 if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3814 {
3815 if (!f_named_ret_val)
3816 f_named_ret_val = BITMAP_GGC_ALLOC ();
3817 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3818 }
3819
3820 /* Note that we need not care about CONSTRUCTORs here, as they are
3821 totally transparent given the read-compose-write semantics of
3822 assignments from CONSTRUCTORs. */
3823 else if (EXPR_P (ret_val))
3824 vec_safe_push (f_other_ret_val, ret_val);
3825 }
3826 }
3827 else
3828 result_expr = ret_obj;
3829
3830 return build1 (RETURN_EXPR, void_type_node, result_expr);
3831 }
3832
3833 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3834 don't return anything. */
3835
3836 static void
Subprogram_Body_to_gnu(Node_Id gnat_node)3837 Subprogram_Body_to_gnu (Node_Id gnat_node)
3838 {
3839 /* Defining identifier of a parameter to the subprogram. */
3840 Entity_Id gnat_param;
3841 /* The defining identifier for the subprogram body. Note that if a
3842 specification has appeared before for this body, then the identifier
3843 occurring in that specification will also be a defining identifier and all
3844 the calls to this subprogram will point to that specification. */
3845 Entity_Id gnat_subprog_id
3846 = (Present (Corresponding_Spec (gnat_node))
3847 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3848 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3849 tree gnu_subprog_decl;
3850 /* Its RESULT_DECL node. */
3851 tree gnu_result_decl;
3852 /* Its FUNCTION_TYPE node. */
3853 tree gnu_subprog_type;
3854 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3855 tree gnu_cico_list;
3856 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3857 tree gnu_return_var_elmt = NULL_TREE;
3858 tree gnu_result;
3859 location_t locus;
3860 struct language_function *gnu_subprog_language;
3861 vec<parm_attr, va_gc> *cache;
3862
3863 /* If this is a generic object or if it has been eliminated,
3864 ignore it. */
3865 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
3866 || Ekind (gnat_subprog_id) == E_Generic_Function
3867 || Is_Eliminated (gnat_subprog_id))
3868 return;
3869
3870 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3871 the already-elaborated tree node. However, if this subprogram had its
3872 elaboration deferred, we will already have made a tree node for it. So
3873 treat it as not being defined in that case. Such a subprogram cannot
3874 have an address clause or a freeze node, so this test is safe, though it
3875 does disable some otherwise-useful error checking. */
3876 gnu_subprog_decl
3877 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
3878 Acts_As_Spec (gnat_node)
3879 && !present_gnu_tree (gnat_subprog_id));
3880 DECL_FUNCTION_IS_DEF (gnu_subprog_decl) = true;
3881 gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
3882 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
3883 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3884 if (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node)
3885 gnu_return_var_elmt = gnu_cico_list;
3886
3887 /* If the function returns by invisible reference, make it explicit in the
3888 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
3889 if (TREE_ADDRESSABLE (gnu_subprog_type))
3890 {
3891 TREE_TYPE (gnu_result_decl)
3892 = build_reference_type (TREE_TYPE (gnu_result_decl));
3893 relayout_decl (gnu_result_decl);
3894 }
3895
3896 /* Set the line number in the decl to correspond to that of the body. */
3897 if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog_decl))
3898 locus = input_location;
3899 DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus;
3900
3901 /* If the body comes from an expression function, arrange it to be inlined
3902 in almost all cases. */
3903 if (Was_Expression_Function (gnat_node))
3904 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog_decl) = 1;
3905
3906 /* Try to create a bona-fide thunk and hand it over to the middle-end. */
3907 if (Is_Thunk (gnat_subprog_id)
3908 && maybe_make_gnu_thunk (gnat_subprog_id, gnu_subprog_decl))
3909 return;
3910
3911 /* Initialize the information structure for the function. */
3912 allocate_struct_function (gnu_subprog_decl, false);
3913 gnu_subprog_language = ggc_cleared_alloc<language_function> ();
3914 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
3915 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_start_locus = locus;
3916 set_cfun (NULL);
3917
3918 begin_subprog_body (gnu_subprog_decl);
3919
3920 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3921 properly copied out by the return statement. We do this by making a new
3922 block and converting any return into a goto to a label at the end of the
3923 block. */
3924 if (gnu_cico_list)
3925 {
3926 tree gnu_return_var = NULL_TREE;
3927
3928 vec_safe_push (gnu_return_label_stack,
3929 create_artificial_label (input_location));
3930
3931 start_stmt_group ();
3932 gnat_pushlevel ();
3933
3934 /* If this is a function with copy-in/copy-out parameters and which does
3935 not return by invisible reference, we also need a variable for the
3936 return value to be placed. */
3937 if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type))
3938 {
3939 tree gnu_return_type
3940 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3941
3942 gnu_return_var
3943 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3944 gnu_return_type, NULL_TREE,
3945 false, false, false, false, false,
3946 true, false, NULL, gnat_subprog_id);
3947 TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3948 }
3949
3950 vec_safe_push (gnu_return_var_stack, gnu_return_var);
3951
3952 /* See whether there are parameters for which we don't have a GCC tree
3953 yet. These must be Out parameters. Make a VAR_DECL for them and
3954 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3955 We can match up the entries because TYPE_CI_CO_LIST is in the order
3956 of the parameters. */
3957 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3958 Present (gnat_param);
3959 gnat_param = Next_Formal_With_Extras (gnat_param))
3960 if (!present_gnu_tree (gnat_param))
3961 {
3962 tree gnu_cico_entry = gnu_cico_list;
3963 tree gnu_decl;
3964
3965 /* Skip any entries that have been already filled in; they must
3966 correspond to In Out parameters. */
3967 while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3968 gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3969
3970 /* Do any needed dereferences for by-ref objects. */
3971 gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, true);
3972 gcc_assert (DECL_P (gnu_decl));
3973 if (DECL_BY_REF_P (gnu_decl))
3974 gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
3975
3976 /* Do any needed references for padded types. */
3977 TREE_VALUE (gnu_cico_entry)
3978 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl);
3979 }
3980 }
3981 else
3982 vec_safe_push (gnu_return_label_stack, NULL_TREE);
3983
3984 /* Get a tree corresponding to the code for the subprogram. */
3985 start_stmt_group ();
3986 gnat_pushlevel ();
3987
3988 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3989
3990 /* Generate the code of the subprogram itself. A return statement will be
3991 present and any Out parameters will be handled there. */
3992 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3993 gnat_poplevel ();
3994 gnu_result = end_stmt_group ();
3995
3996 /* Attempt setting the end_locus of our GCC body tree, typically a BIND_EXPR,
3997 then the end_locus of our GCC subprogram declaration tree. */
3998 set_end_locus_from_node (gnu_result, gnat_node);
3999 set_end_locus_from_node (gnu_subprog_decl, gnat_node);
4000
4001 /* If we populated the parameter attributes cache, we need to make sure that
4002 the cached expressions are evaluated on all the possible paths leading to
4003 their uses. So we force their evaluation on entry of the function. */
4004 cache = gnu_subprog_language->parm_attr_cache;
4005 if (cache)
4006 {
4007 struct parm_attr_d *pa;
4008 int i;
4009
4010 start_stmt_group ();
4011
4012 FOR_EACH_VEC_ELT (*cache, i, pa)
4013 {
4014 if (pa->first)
4015 add_stmt_with_node_force (pa->first, gnat_node);
4016 if (pa->last)
4017 add_stmt_with_node_force (pa->last, gnat_node);
4018 if (pa->length)
4019 add_stmt_with_node_force (pa->length, gnat_node);
4020 }
4021
4022 add_stmt (gnu_result);
4023 gnu_result = end_stmt_group ();
4024
4025 gnu_subprog_language->parm_attr_cache = NULL;
4026 }
4027
4028 /* If we are dealing with a return from an Ada procedure with parameters
4029 passed by copy-in/copy-out, we need to return a record containing the
4030 final values of these parameters. If the list contains only one entry,
4031 return just that entry though.
4032
4033 For a full description of the copy-in/copy-out parameter mechanism, see
4034 the part of the gnat_to_gnu_entity routine dealing with the translation
4035 of subprograms.
4036
4037 We need to make a block that contains the definition of that label and
4038 the copying of the return value. It first contains the function, then
4039 the label and copy statement. */
4040 if (gnu_cico_list)
4041 {
4042 const Node_Id gnat_end_label
4043 = End_Label (Handled_Statement_Sequence (gnat_node));
4044
4045 gnu_return_var_stack->pop ();
4046
4047 add_stmt (gnu_result);
4048 add_stmt (build1 (LABEL_EXPR, void_type_node,
4049 gnu_return_label_stack->last ()));
4050
4051 /* If this is a function which returns by invisible reference, the
4052 return value has already been dealt with at the return statements,
4053 so we only need to indirectly copy out the parameters. */
4054 if (TREE_ADDRESSABLE (gnu_subprog_type))
4055 {
4056 tree gnu_ret_deref
4057 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl);
4058 tree t;
4059
4060 gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node);
4061
4062 for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t))
4063 {
4064 tree gnu_field_deref
4065 = build_component_ref (gnu_ret_deref, TREE_PURPOSE (t), true);
4066 gnu_result = build2 (MODIFY_EXPR, void_type_node,
4067 gnu_field_deref, TREE_VALUE (t));
4068 add_stmt_with_node (gnu_result, gnat_end_label);
4069 }
4070 }
4071
4072 /* Otherwise, if this is a procedure or a function which does not return
4073 by invisible reference, we can do a direct block-copy out. */
4074 else
4075 {
4076 tree gnu_retval;
4077
4078 if (list_length (gnu_cico_list) == 1)
4079 gnu_retval = TREE_VALUE (gnu_cico_list);
4080 else
4081 gnu_retval
4082 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
4083 gnu_cico_list);
4084
4085 gnu_result = build_return_expr (gnu_result_decl, gnu_retval);
4086 add_stmt_with_node (gnu_result, gnat_end_label);
4087 }
4088
4089 gnat_poplevel ();
4090 gnu_result = end_stmt_group ();
4091 }
4092
4093 gnu_return_label_stack->pop ();
4094
4095 /* On SEH targets, install an exception handler around the main entry
4096 point to catch unhandled exceptions. */
4097 if (DECL_NAME (gnu_subprog_decl) == main_identifier_node
4098 && targetm_common.except_unwind_info (&global_options) == UI_SEH)
4099 {
4100 tree t;
4101 tree etype;
4102
4103 t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
4104 1, integer_zero_node);
4105 t = build_call_n_expr (unhandled_except_decl, 1, t);
4106
4107 etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl);
4108 etype = tree_cons (NULL_TREE, etype, NULL_TREE);
4109
4110 t = build2 (CATCH_EXPR, void_type_node, etype, t);
4111 gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result),
4112 gnu_result, t);
4113 }
4114
4115 end_subprog_body (gnu_result);
4116
4117 /* Finally annotate the parameters and disconnect the trees for parameters
4118 that we have turned into variables since they are now unusable. */
4119 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
4120 Present (gnat_param);
4121 gnat_param = Next_Formal_With_Extras (gnat_param))
4122 {
4123 tree gnu_param = get_gnu_tree (gnat_param);
4124 bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
4125
4126 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
4127 DECL_BY_REF_P (gnu_param));
4128
4129 if (is_var_decl)
4130 save_gnu_tree (gnat_param, NULL_TREE, false);
4131 }
4132
4133 /* Disconnect the variable created for the return value. */
4134 if (gnu_return_var_elmt)
4135 TREE_VALUE (gnu_return_var_elmt) = void_type_node;
4136
4137 /* If the function returns an aggregate type and we have candidates for
4138 a Named Return Value, finalize the optimization. */
4139 if (optimize && !optimize_debug && gnu_subprog_language->named_ret_val)
4140 {
4141 finalize_nrv (gnu_subprog_decl,
4142 gnu_subprog_language->named_ret_val,
4143 gnu_subprog_language->other_ret_val,
4144 gnu_subprog_language->gnat_ret);
4145 gnu_subprog_language->named_ret_val = NULL;
4146 gnu_subprog_language->other_ret_val = NULL;
4147 }
4148
4149 /* If this is an inlined external function that has been marked uninlinable,
4150 drop the body and stop there. Otherwise compile the body. */
4151 if (DECL_EXTERNAL (gnu_subprog_decl) && DECL_UNINLINABLE (gnu_subprog_decl))
4152 DECL_SAVED_TREE (gnu_subprog_decl) = NULL_TREE;
4153 else
4154 rest_of_subprog_body_compilation (gnu_subprog_decl);
4155 }
4156
4157 /* The type of an atomic access. */
4158
4159 typedef enum { NOT_ATOMIC, SIMPLE_ATOMIC, OUTER_ATOMIC } atomic_acces_t;
4160
4161 /* Return true if GNAT_NODE references an Atomic entity. This is modeled on
4162 the Is_Atomic_Object predicate of the front-end, but additionally handles
4163 explicit dereferences. */
4164
4165 static bool
node_is_atomic(Node_Id gnat_node)4166 node_is_atomic (Node_Id gnat_node)
4167 {
4168 Entity_Id gnat_entity;
4169
4170 switch (Nkind (gnat_node))
4171 {
4172 case N_Identifier:
4173 case N_Expanded_Name:
4174 gnat_entity = Entity (gnat_node);
4175 if (Ekind (gnat_entity) != E_Variable)
4176 break;
4177 return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
4178
4179 case N_Selected_Component:
4180 return Is_Atomic (Etype (gnat_node))
4181 || Is_Atomic (Entity (Selector_Name (gnat_node)));
4182
4183 case N_Indexed_Component:
4184 return Is_Atomic (Etype (gnat_node))
4185 || Has_Atomic_Components (Etype (Prefix (gnat_node)))
4186 || (Is_Entity_Name (Prefix (gnat_node))
4187 && Has_Atomic_Components (Entity (Prefix (gnat_node))));
4188
4189 case N_Explicit_Dereference:
4190 return Is_Atomic (Etype (gnat_node));
4191
4192 default:
4193 break;
4194 }
4195
4196 return false;
4197 }
4198
4199 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. This is
4200 modeled on the Is_Volatile_Full_Access_Object predicate of the front-end,
4201 but additionally handles explicit dereferences. */
4202
4203 static bool
node_is_volatile_full_access(Node_Id gnat_node)4204 node_is_volatile_full_access (Node_Id gnat_node)
4205 {
4206 Entity_Id gnat_entity;
4207
4208 switch (Nkind (gnat_node))
4209 {
4210 case N_Identifier:
4211 case N_Expanded_Name:
4212 gnat_entity = Entity (gnat_node);
4213 if (!Is_Object (gnat_entity))
4214 break;
4215 return Is_Volatile_Full_Access (gnat_entity)
4216 || Is_Volatile_Full_Access (Etype (gnat_entity));
4217
4218 case N_Selected_Component:
4219 return Is_Volatile_Full_Access (Etype (gnat_node))
4220 || Is_Volatile_Full_Access (Entity (Selector_Name (gnat_node)));
4221
4222 case N_Indexed_Component:
4223 case N_Explicit_Dereference:
4224 return Is_Volatile_Full_Access (Etype (gnat_node));
4225
4226 default:
4227 break;
4228 }
4229
4230 return false;
4231 }
4232
4233 /* Return true if GNAT_NODE references a component of a larger object. */
4234
4235 static inline bool
node_is_component(Node_Id gnat_node)4236 node_is_component (Node_Id gnat_node)
4237 {
4238 const Node_Kind k = Nkind (gnat_node);
4239 return
4240 (k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice);
4241 }
4242
4243 /* Compute whether GNAT_NODE requires atomic access and set TYPE to the type
4244 of access and SYNC according to the associated synchronization setting.
4245
4246 We implement 3 different semantics of atomicity in this function:
4247
4248 1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma,
4249 2. the Ada 2020 semantics of the Atomic aspect/pragma,
4250 3. the semantics of the Volatile_Full_Access GNAT aspect/pragma.
4251
4252 They are mutually exclusive and the FE should have rejected conflicts. */
4253
4254 static void
get_atomic_access(Node_Id gnat_node,atomic_acces_t * type,bool * sync)4255 get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync)
4256 {
4257 Node_Id gnat_parent, gnat_temp;
4258 unsigned char attr_id;
4259
4260 /* First, scan the parent to filter out irrelevant cases. */
4261 gnat_parent = Parent (gnat_node);
4262 switch (Nkind (gnat_parent))
4263 {
4264 case N_Attribute_Reference:
4265 attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
4266 /* Do not mess up machine code insertions. */
4267 if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
4268 goto not_atomic;
4269
4270 /* Nothing to do if we are the prefix of an attribute, since we do not
4271 want an atomic access for things like 'Size. */
4272
4273 /* ... fall through ... */
4274
4275 case N_Reference:
4276 /* The N_Reference node is like an attribute. */
4277 if (Prefix (gnat_parent) == gnat_node)
4278 goto not_atomic;
4279 break;
4280
4281 case N_Object_Renaming_Declaration:
4282 /* Nothing to do for the identifier in an object renaming declaration,
4283 the renaming itself does not need atomic access. */
4284 goto not_atomic;
4285
4286 default:
4287 break;
4288 }
4289
4290 /* Now strip any type conversion from GNAT_NODE. */
4291 if (Nkind (gnat_node) == N_Type_Conversion
4292 || Nkind (gnat_node) == N_Unchecked_Type_Conversion)
4293 gnat_node = Expression (gnat_node);
4294
4295 /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
4296 a whole require atomic access (RM C.6(15)). But, starting with Ada 2020,
4297 reads of or writes to a nonatomic subcomponent of the object also require
4298 atomic access (RM C.6(19)). */
4299 if (node_is_atomic (gnat_node))
4300 {
4301 bool as_a_whole = true;
4302
4303 /* If we are the prefix of the parent, then the access is partial. */
4304 for (gnat_temp = gnat_node, gnat_parent = Parent (gnat_temp);
4305 node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_temp;
4306 gnat_temp = gnat_parent, gnat_parent = Parent (gnat_temp))
4307 if (Ada_Version < Ada_2020 || node_is_atomic (gnat_parent))
4308 goto not_atomic;
4309 else
4310 as_a_whole = false;
4311
4312 /* We consider that partial accesses are not sequential actions and,
4313 therefore, do not require synchronization. */
4314 *type = SIMPLE_ATOMIC;
4315 *sync = as_a_whole ? Atomic_Sync_Required (gnat_node) : false;
4316 return;
4317 }
4318
4319 /* Look for an outer atomic access of a nonatomic subcomponent. Note that,
4320 for VFA, we do this before looking at the node itself because we need to
4321 access the outermost VFA object atomically, unlike for Atomic where it is
4322 the innermost atomic object (RM C.6(19)). */
4323 for (gnat_temp = gnat_node;
4324 node_is_component (gnat_temp);
4325 gnat_temp = Prefix (gnat_temp))
4326 if ((Ada_Version >= Ada_2020 && node_is_atomic (Prefix (gnat_temp)))
4327 || node_is_volatile_full_access (Prefix (gnat_temp)))
4328 {
4329 *type = OUTER_ATOMIC;
4330 *sync = false;
4331 return;
4332 }
4333
4334 /* Unlike Atomic, accessing a VFA object always requires atomic access. */
4335 if (node_is_volatile_full_access (gnat_node))
4336 {
4337 *type = SIMPLE_ATOMIC;
4338 *sync = false;
4339 return;
4340 }
4341
4342 not_atomic:
4343 *type = NOT_ATOMIC;
4344 *sync = false;
4345 }
4346
4347 /* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
4348 according to the associated synchronization setting. */
4349
4350 static inline bool
simple_atomic_access_required_p(Node_Id gnat_node,bool * sync)4351 simple_atomic_access_required_p (Node_Id gnat_node, bool *sync)
4352 {
4353 atomic_acces_t type;
4354 get_atomic_access (gnat_node, &type, sync);
4355 return type == SIMPLE_ATOMIC;
4356 }
4357
4358 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4359
4360 static tree
create_temporary(const char * prefix,tree type)4361 create_temporary (const char *prefix, tree type)
4362 {
4363 tree gnu_temp
4364 = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
4365 type, NULL_TREE,
4366 false, false, false, false, false,
4367 true, false, NULL, Empty);
4368 return gnu_temp;
4369 }
4370
4371 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4372 Put the initialization statement into GNU_INIT_STMT and annotate it with
4373 the SLOC of GNAT_NODE. Return the temporary variable. */
4374
4375 static tree
create_init_temporary(const char * prefix,tree gnu_init,tree * gnu_init_stmt,Node_Id gnat_node)4376 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
4377 Node_Id gnat_node)
4378 {
4379 tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
4380
4381 *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
4382 set_expr_location_from_node (*gnu_init_stmt, gnat_node);
4383
4384 return gnu_temp;
4385 }
4386
4387 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4388 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4389 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4390 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4391 N_Assignment_Statement and the result is to be placed into that object.
4392 ATOMIC_ACCESS is the type of atomic access to be used for the assignment
4393 to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment
4394 to GNU_TARGET requires atomic synchronization. */
4395
4396 static tree
Call_to_gnu(Node_Id gnat_node,tree * gnu_result_type_p,tree gnu_target,atomic_acces_t atomic_access,bool atomic_sync)4397 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
4398 atomic_acces_t atomic_access, bool atomic_sync)
4399 {
4400 const bool function_call = (Nkind (gnat_node) == N_Function_Call);
4401 const bool returning_value = (function_call && !gnu_target);
4402 /* The GCC node corresponding to the GNAT subprogram name. This can either
4403 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4404 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4405 subprogram. */
4406 tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
4407 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4408 tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
4409 /* The return type of the FUNCTION_TYPE. */
4410 tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
4411 const bool frontend_builtin
4412 = (TREE_CODE (gnu_subprog) == FUNCTION_DECL
4413 && DECL_BUILT_IN_CLASS (gnu_subprog) == BUILT_IN_FRONTEND);
4414 auto_vec<tree, 16> gnu_actual_vec;
4415 tree gnu_name_list = NULL_TREE;
4416 tree gnu_stmt_list = NULL_TREE;
4417 tree gnu_after_list = NULL_TREE;
4418 tree gnu_retval = NULL_TREE;
4419 tree gnu_call, gnu_result;
4420 bool went_into_elab_proc = false;
4421 bool pushed_binding_level = false;
4422 bool variadic;
4423 bool by_descriptor;
4424 Entity_Id gnat_formal;
4425 Node_Id gnat_actual;
4426 atomic_acces_t aa_type;
4427 bool aa_sync;
4428
4429 gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type));
4430
4431 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
4432 all our args first. */
4433 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
4434 {
4435 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
4436 gnat_node, N_Raise_Program_Error);
4437
4438 for (gnat_actual = First_Actual (gnat_node);
4439 Present (gnat_actual);
4440 gnat_actual = Next_Actual (gnat_actual))
4441 add_stmt (gnat_to_gnu (gnat_actual));
4442
4443 if (returning_value)
4444 {
4445 *gnu_result_type_p = gnu_result_type;
4446 return build1 (NULL_EXPR, gnu_result_type, call_expr);
4447 }
4448
4449 return call_expr;
4450 }
4451
4452 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL)
4453 {
4454 /* For a call to a nested function, check the inlining status. */
4455 if (decl_function_context (gnu_subprog))
4456 check_inlining_for_nested_subprog (gnu_subprog);
4457
4458 /* For a recursive call, avoid explosion due to recursive inlining. */
4459 if (gnu_subprog == current_function_decl)
4460 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog) = 0;
4461 }
4462
4463 /* The only way we can be making a call via an access type is if Name is an
4464 explicit dereference. In that case, get the list of formal args from the
4465 type the access type is pointing to. Otherwise, get the formals from the
4466 entity being called. */
4467 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4468 {
4469 const Entity_Id gnat_prefix_type
4470 = Underlying_Type (Etype (Prefix (Name (gnat_node))));
4471
4472 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4473 variadic = IN (Convention (gnat_prefix_type), Convention_C_Variadic);
4474
4475 /* If the access type doesn't require foreign-compatible representation,
4476 be prepared for descriptors. */
4477 by_descriptor
4478 = targetm.calls.custom_function_descriptors > 0
4479 && Can_Use_Internal_Rep (gnat_prefix_type);
4480 }
4481 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
4482 {
4483 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4484 gnat_formal = Empty;
4485 variadic = false;
4486 by_descriptor = false;
4487 }
4488 else
4489 {
4490 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4491 variadic
4492 = IN (Convention (Entity (Name (gnat_node))), Convention_C_Variadic);
4493 by_descriptor = false;
4494 }
4495
4496 /* The lifetime of the temporaries created for the call ends right after the
4497 return value is copied, so we can give them the scope of the elaboration
4498 routine at top level. */
4499 if (!current_function_decl)
4500 {
4501 current_function_decl = get_elaboration_procedure ();
4502 went_into_elab_proc = true;
4503 }
4504
4505 /* First, create the temporary for the return value when:
4506
4507 1. There is no target and the function has copy-in/copy-out parameters,
4508 because we need to preserve the return value before copying back the
4509 parameters.
4510
4511 2. There is no target and the call is made for neither an object, nor a
4512 renaming declaration, nor a return statement, nor an allocator, and
4513 the return type has variable size because in this case the gimplifier
4514 cannot create the temporary, or more generally is an aggregate type,
4515 because the gimplifier would create the temporary in the outermost
4516 scope instead of locally. But there is an exception for an allocator
4517 of an unconstrained record type with default discriminant because we
4518 allocate the actual size in this case, unlike the other 3 cases, so
4519 we need a temporary to fetch the discriminant and we create it here.
4520
4521 3. There is a target and it is a slice or an array with fixed size,
4522 and the return type has variable size, because the gimplifier
4523 doesn't handle these cases.
4524
4525 4. There is a target which is a bit-field and the function returns an
4526 unconstrained record type with default discriminant, because the
4527 return may copy more data than the bit-field can contain.
4528
4529 5. There is no target and we have misaligned In Out or Out parameters
4530 passed by reference, because we need to preserve the return value
4531 before copying back the parameters. However, in this case, we'll
4532 defer creating the temporary, see below.
4533
4534 This must be done before we push a binding level around the call, since
4535 we will pop it before copying the return value. */
4536 if (function_call
4537 && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
4538 || (!gnu_target
4539 && Nkind (Parent (gnat_node)) != N_Object_Declaration
4540 && Nkind (Parent (gnat_node)) != N_Object_Renaming_Declaration
4541 && Nkind (Parent (gnat_node)) != N_Simple_Return_Statement
4542 && (!(Nkind (Parent (gnat_node)) == N_Qualified_Expression
4543 && Nkind (Parent (Parent (gnat_node))) == N_Allocator)
4544 || type_is_padding_self_referential (gnu_result_type))
4545 && AGGREGATE_TYPE_P (gnu_result_type)
4546 && !TYPE_IS_FAT_POINTER_P (gnu_result_type))
4547 || (gnu_target
4548 && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
4549 || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
4550 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
4551 == INTEGER_CST))
4552 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
4553 || (gnu_target
4554 && TREE_CODE (gnu_target) == COMPONENT_REF
4555 && DECL_BIT_FIELD (TREE_OPERAND (gnu_target, 1))
4556 && DECL_SIZE (TREE_OPERAND (gnu_target, 1))
4557 != TYPE_SIZE (TREE_TYPE (gnu_target))
4558 && type_is_padding_self_referential (gnu_result_type))))
4559 {
4560 gnu_retval = create_temporary ("R", gnu_result_type);
4561 DECL_RETURN_VALUE_P (gnu_retval) = 1;
4562 }
4563
4564 /* If we don't need a value or have already created it, push a binding level
4565 around the call. This will narrow the lifetime of the temporaries we may
4566 need to make when translating the parameters as much as possible. */
4567 if (!returning_value || gnu_retval)
4568 {
4569 start_stmt_group ();
4570 gnat_pushlevel ();
4571 pushed_binding_level = true;
4572 }
4573
4574 /* Create the list of the actual parameters as GCC expects it, namely a
4575 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4576 is an expression and the TREE_PURPOSE field is null. But skip Out
4577 parameters not passed by reference and that need not be copied in. */
4578 for (gnat_actual = First_Actual (gnat_node);
4579 Present (gnat_actual);
4580 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4581 gnat_actual = Next_Actual (gnat_actual))
4582 {
4583 Entity_Id gnat_formal_type = Etype (gnat_formal);
4584 tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
4585 tree gnu_formal = present_gnu_tree (gnat_formal)
4586 ? get_gnu_tree (gnat_formal) : NULL_TREE;
4587 const bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
4588 const bool is_true_formal_parm
4589 = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
4590 const bool is_by_ref_formal_parm
4591 = is_true_formal_parm
4592 && (DECL_BY_REF_P (gnu_formal)
4593 || DECL_BY_COMPONENT_PTR_P (gnu_formal));
4594 /* In the In Out or Out case, we must suppress conversions that yield
4595 an lvalue but can nevertheless cause the creation of a temporary,
4596 because we need the real object in this case, either to pass its
4597 address if it's passed by reference or as target of the back copy
4598 done after the call if it uses the copy-in/copy-out mechanism.
4599 We do it in the In case too, except for an unchecked conversion
4600 to an elementary type or a constrained composite type because it
4601 alone can cause the actual to be misaligned and the addressability
4602 test is applied to the real object. */
4603 const bool suppress_type_conversion
4604 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
4605 && (!in_param
4606 || !is_by_ref_formal_parm
4607 || (Is_Composite_Type (Underlying_Type (gnat_formal_type))
4608 && !Is_Constrained (Underlying_Type (gnat_formal_type)))))
4609 || (Nkind (gnat_actual) == N_Type_Conversion
4610 && Is_Composite_Type (Underlying_Type (gnat_formal_type))));
4611 Node_Id gnat_name = suppress_type_conversion
4612 ? Expression (gnat_actual) : gnat_actual;
4613 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
4614
4615 /* If it's possible we may need to use this expression twice, make sure
4616 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4617 to force side-effects before the call. */
4618 if (!in_param && !is_by_ref_formal_parm)
4619 {
4620 tree init = NULL_TREE;
4621 gnu_name = gnat_stabilize_reference (gnu_name, true, &init);
4622 if (init)
4623 gnu_name
4624 = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
4625 }
4626
4627 /* If we are passing a non-addressable parameter by reference, pass the
4628 address of a copy. In the In Out or Out case, set up to copy back
4629 out after the call. */
4630 if (is_by_ref_formal_parm
4631 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
4632 && !addressable_p (gnu_name, gnu_name_type))
4633 {
4634 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
4635
4636 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4637 but sort of an instantiation for them. */
4638 if (TREE_CODE (remove_conversions (gnu_name, true)) == CONSTRUCTOR)
4639 ;
4640
4641 /* If the formal is passed by reference, a copy is not allowed. */
4642 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type)
4643 || Is_Aliased (gnat_formal))
4644 post_error ("misaligned actual cannot be passed by reference",
4645 gnat_actual);
4646
4647 /* If the mechanism was forced to by-ref, a copy is not allowed but
4648 we issue only a warning because this case is not strict Ada. */
4649 else if (DECL_FORCED_BY_REF_P (gnu_formal))
4650 post_error ("misaligned actual cannot be passed by reference??",
4651 gnat_actual);
4652
4653 /* If the actual type of the object is already the nominal type,
4654 we have nothing to do, except if the size is self-referential
4655 in which case we'll remove the unpadding below. */
4656 if (TREE_TYPE (gnu_name) == gnu_name_type
4657 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
4658 ;
4659
4660 /* Otherwise remove the unpadding from all the objects. */
4661 else if (TREE_CODE (gnu_name) == COMPONENT_REF
4662 && TYPE_IS_PADDING_P
4663 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
4664 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
4665
4666 /* Otherwise convert to the nominal type of the object if needed.
4667 There are several cases in which we need to make the temporary
4668 using this type instead of the actual type of the object when
4669 they are distinct, because the expectations of the callee would
4670 otherwise not be met:
4671 - if it's a justified modular type,
4672 - if the actual type is a smaller form of it,
4673 - if it's a smaller form of the actual type. */
4674 else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
4675 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
4676 || smaller_form_type_p (TREE_TYPE (gnu_name),
4677 gnu_name_type)))
4678 || (INTEGRAL_TYPE_P (gnu_name_type)
4679 && smaller_form_type_p (gnu_name_type,
4680 TREE_TYPE (gnu_name))))
4681 gnu_name = convert (gnu_name_type, gnu_name);
4682
4683 /* If this is an In Out or Out parameter and we're returning a value,
4684 we need to create a temporary for the return value because we must
4685 preserve it before copying back at the very end. */
4686 if (!in_param && returning_value && !gnu_retval)
4687 {
4688 gnu_retval = create_temporary ("R", gnu_result_type);
4689 DECL_RETURN_VALUE_P (gnu_retval) = 1;
4690 }
4691
4692 /* If we haven't pushed a binding level, push it now. This will
4693 narrow the lifetime of the temporary we are about to make as
4694 much as possible. */
4695 if (!pushed_binding_level && (!returning_value || gnu_retval))
4696 {
4697 start_stmt_group ();
4698 gnat_pushlevel ();
4699 pushed_binding_level = true;
4700 }
4701
4702 /* Create an explicit temporary holding the copy. */
4703 /* Do not initialize it for the _Init parameter of an initialization
4704 procedure since no data is meant to be passed in. */
4705 if (Ekind (gnat_formal) == E_Out_Parameter
4706 && Is_Entity_Name (Name (gnat_node))
4707 && Is_Init_Proc (Entity (Name (gnat_node))))
4708 gnu_name = gnu_temp = create_temporary ("A", TREE_TYPE (gnu_name));
4709
4710 /* Initialize it on the fly like for an implicit temporary in the
4711 other cases, as we don't necessarily have a statement list. */
4712 else
4713 {
4714 gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt,
4715 gnat_actual);
4716 gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
4717 gnu_temp);
4718 }
4719
4720 /* Set up to move the copy back to the original if needed. */
4721 if (!in_param)
4722 {
4723 /* If the original is a COND_EXPR whose first arm isn't meant to
4724 be further used, just deal with the second arm. This is very
4725 likely the conditional expression built for a check. */
4726 if (TREE_CODE (gnu_orig) == COND_EXPR
4727 && TREE_CODE (TREE_OPERAND (gnu_orig, 1)) == COMPOUND_EXPR
4728 && integer_zerop
4729 (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
4730 gnu_orig = TREE_OPERAND (gnu_orig, 2);
4731
4732 gnu_stmt
4733 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
4734 set_expr_location_from_node (gnu_stmt, gnat_node);
4735
4736 append_to_statement_list (gnu_stmt, &gnu_after_list);
4737 }
4738 }
4739
4740 /* Start from the real object and build the actual. */
4741 tree gnu_actual = gnu_name;
4742
4743 /* If atomic access is required for an In or In Out actual parameter,
4744 build the atomic load. */
4745 if (is_true_formal_parm
4746 && !is_by_ref_formal_parm
4747 && Ekind (gnat_formal) != E_Out_Parameter
4748 && simple_atomic_access_required_p (gnat_actual, &aa_sync))
4749 gnu_actual = build_atomic_load (gnu_actual, aa_sync);
4750
4751 /* If this was a procedure call, we may not have removed any padding.
4752 So do it here for the part we will use as an input, if any. */
4753 if (Ekind (gnat_formal) != E_Out_Parameter
4754 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4755 gnu_actual
4756 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
4757
4758 /* Put back the conversion we suppressed above in the computation of the
4759 real object. And even if we didn't suppress any conversion there, we
4760 may have suppressed a conversion to the Etype of the actual earlier,
4761 since the parent is a procedure call, so put it back here. Note that
4762 we might have a dummy type here if the actual is the dereference of a
4763 pointer to it, but that's OK if the formal is passed by reference. */
4764 tree gnu_actual_type = get_unpadded_type (Etype (gnat_actual));
4765 if (TYPE_IS_DUMMY_P (gnu_actual_type))
4766 gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal));
4767 else if (suppress_type_conversion
4768 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4769 gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual,
4770 No_Truncation (gnat_actual));
4771 else
4772 gnu_actual = convert (gnu_actual_type, gnu_actual);
4773
4774 gigi_checking_assert (!Do_Range_Check (gnat_actual));
4775
4776 /* First see if the parameter is passed by reference. */
4777 if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
4778 {
4779 if (!in_param)
4780 {
4781 /* In Out or Out parameters passed by reference don't use the
4782 copy-in/copy-out mechanism so the address of the real object
4783 must be passed to the function. */
4784 gnu_actual = gnu_name;
4785
4786 /* If we have a padded type, be sure we've removed padding. */
4787 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4788 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
4789 gnu_actual);
4790
4791 /* If we have the constructed subtype of an aliased object
4792 with an unconstrained nominal subtype, the type of the
4793 actual includes the template, although it is formally
4794 constrained. So we need to convert it back to the real
4795 constructed subtype to retrieve the constrained part
4796 and takes its address. */
4797 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
4798 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
4799 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
4800 && Is_Array_Type (Underlying_Type (Etype (gnat_actual))))
4801 gnu_actual = convert (gnu_actual_type, gnu_actual);
4802 }
4803
4804 /* There is no need to convert the actual to the formal's type before
4805 taking its address. The only exception is for unconstrained array
4806 types because of the way we build fat pointers. */
4807 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4808 {
4809 /* Put back the conversion we suppressed above for In Out or Out
4810 parameters, since it may set the bounds of the actual. */
4811 if (!in_param && suppress_type_conversion)
4812 gnu_actual = convert (gnu_actual_type, gnu_actual);
4813 gnu_actual = convert (gnu_formal_type, gnu_actual);
4814 }
4815
4816 /* Take the address of the object and convert to the proper pointer
4817 type. */
4818 gnu_formal_type = TREE_TYPE (gnu_formal);
4819 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4820 }
4821
4822 /* Then see if the parameter is an array passed to a foreign convention
4823 subprogram. */
4824 else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
4825 {
4826 gnu_actual = maybe_padded_object (gnu_actual);
4827 gnu_actual = maybe_unconstrained_array (gnu_actual);
4828
4829 /* Take the address of the object and convert to the proper pointer
4830 type. We'd like to actually compute the address of the beginning
4831 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4832 possibility that the ARRAY_REF might return a constant and we'd be
4833 getting the wrong address. Neither approach is exactly correct,
4834 but this is the most likely to work in all cases. */
4835 gnu_formal_type = TREE_TYPE (gnu_formal);
4836 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4837 }
4838
4839 /* Then see if the parameter is passed by copy. */
4840 else if (is_true_formal_parm)
4841 {
4842 if (!in_param)
4843 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
4844
4845 gnu_actual = convert (gnu_formal_type, gnu_actual);
4846
4847 /* If this is a front-end built-in function, there is no need to
4848 convert to the type used to pass the argument. */
4849 if (!frontend_builtin)
4850 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
4851 }
4852
4853 /* Then see if this is an unnamed parameter in a variadic C function. */
4854 else if (variadic)
4855 {
4856 /* This is based on the processing done in gnat_to_gnu_param, but
4857 we expect the mechanism to be set in (almost) all cases. */
4858 const Mechanism_Type mech = Mechanism (gnat_formal);
4859
4860 /* Strip off possible padding type. */
4861 if (TYPE_IS_PADDING_P (gnu_formal_type))
4862 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
4863
4864 /* Arrays are passed as pointers to element type. First check for
4865 unconstrained array and get the underlying array. */
4866 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4867 gnu_formal_type
4868 = TREE_TYPE
4869 (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type))));
4870
4871 /* Arrays are passed as pointers to element type. */
4872 if (mech != By_Copy && TREE_CODE (gnu_formal_type) == ARRAY_TYPE)
4873 {
4874 gnu_actual = maybe_padded_object (gnu_actual);
4875 gnu_actual = maybe_unconstrained_array (gnu_actual);
4876
4877 /* Strip off any multi-dimensional entries, then strip
4878 off the last array to get the component type. */
4879 while (TREE_CODE (TREE_TYPE (gnu_formal_type)) == ARRAY_TYPE
4880 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type)))
4881 gnu_formal_type = TREE_TYPE (gnu_formal_type);
4882
4883 gnu_formal_type = TREE_TYPE (gnu_formal_type);
4884 gnu_formal_type = build_pointer_type (gnu_formal_type);
4885 gnu_actual
4886 = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4887 }
4888
4889 /* Fat pointers are passed as thin pointers. */
4890 else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type))
4891 gnu_formal_type
4892 = make_type_from_size (gnu_formal_type,
4893 size_int (POINTER_SIZE), 0);
4894
4895 /* If we were requested or muss pass by reference, do so.
4896 If we were requested to pass by copy, do so.
4897 Otherwise, pass In Out or Out parameters or aggregates by
4898 reference. */
4899 else if (mech == By_Reference
4900 || must_pass_by_ref (gnu_formal_type)
4901 || (mech != By_Copy
4902 && (!in_param || AGGREGATE_TYPE_P (gnu_formal_type))))
4903 {
4904 gnu_formal_type = build_reference_type (gnu_formal_type);
4905 gnu_actual
4906 = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4907 }
4908
4909 /* Otherwise pass by copy after applying default C promotions. */
4910 else
4911 {
4912 if (INTEGRAL_TYPE_P (gnu_formal_type)
4913 && TYPE_PRECISION (gnu_formal_type)
4914 < TYPE_PRECISION (integer_type_node))
4915 gnu_formal_type = integer_type_node;
4916
4917 else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type)
4918 && TYPE_PRECISION (gnu_formal_type)
4919 < TYPE_PRECISION (double_type_node))
4920 gnu_formal_type = double_type_node;
4921 }
4922
4923 gnu_actual = convert (gnu_formal_type, gnu_actual);
4924 }
4925
4926 /* If we didn't create a PARM_DECL for the formal, this means that
4927 it is an Out parameter not passed by reference and that need not
4928 be copied in. In this case, the value of the actual need not be
4929 read. However, we still need to make sure that its side-effects
4930 are evaluated before the call, so we evaluate its address. */
4931 else
4932 {
4933 if (!in_param)
4934 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
4935
4936 if (TREE_SIDE_EFFECTS (gnu_name))
4937 {
4938 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
4939 append_to_statement_list (addr, &gnu_stmt_list);
4940 }
4941
4942 continue;
4943 }
4944
4945 gnu_actual_vec.safe_push (gnu_actual);
4946 }
4947
4948 if (frontend_builtin)
4949 {
4950 tree pred_cst = build_int_cst (integer_type_node, PRED_BUILTIN_EXPECT);
4951 enum internal_fn icode = IFN_BUILTIN_EXPECT;
4952
4953 switch (DECL_FE_FUNCTION_CODE (gnu_subprog))
4954 {
4955 case BUILT_IN_EXPECT:
4956 break;
4957 case BUILT_IN_LIKELY:
4958 gnu_actual_vec.safe_push (boolean_true_node);
4959 break;
4960 case BUILT_IN_UNLIKELY:
4961 gnu_actual_vec.safe_push (boolean_false_node);
4962 break;
4963 default:
4964 gcc_unreachable ();
4965 }
4966
4967 gnu_actual_vec.safe_push (pred_cst);
4968
4969 gnu_call
4970 = build_call_expr_internal_loc_array (UNKNOWN_LOCATION,
4971 icode,
4972 gnu_result_type,
4973 gnu_actual_vec.length (),
4974 gnu_actual_vec.begin ());
4975 }
4976 else
4977 {
4978 gnu_call
4979 = build_call_array_loc (UNKNOWN_LOCATION,
4980 gnu_result_type,
4981 build_unary_op (ADDR_EXPR, NULL_TREE,
4982 gnu_subprog),
4983 gnu_actual_vec.length (),
4984 gnu_actual_vec.begin ());
4985 CALL_EXPR_BY_DESCRIPTOR (gnu_call) = by_descriptor;
4986 }
4987
4988 set_expr_location_from_node (gnu_call, gnat_node);
4989
4990 /* If we have created a temporary for the return value, initialize it. */
4991 if (gnu_retval)
4992 {
4993 tree gnu_stmt
4994 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
4995 set_expr_location_from_node (gnu_stmt, gnat_node);
4996 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4997 gnu_call = gnu_retval;
4998 }
4999
5000 /* If this is a subprogram with copy-in/copy-out parameters, we need to
5001 unpack the valued returned from the function into the In Out or Out
5002 parameters. We deal with the function return (if this is an Ada
5003 function) below. */
5004 if (TYPE_CI_CO_LIST (gnu_subprog_type))
5005 {
5006 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
5007 copy-out parameters. */
5008 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
5009 const int length = list_length (gnu_cico_list);
5010
5011 /* The call sequence must contain one and only one call, even though the
5012 function is pure. Save the result into a temporary if needed. */
5013 if (length > 1)
5014 {
5015 if (!gnu_retval)
5016 {
5017 tree gnu_stmt;
5018 gnu_call
5019 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
5020 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
5021 }
5022
5023 gnu_name_list = nreverse (gnu_name_list);
5024 }
5025
5026 /* The first entry is for the actual return value if this is a
5027 function, so skip it. */
5028 if (function_call)
5029 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
5030
5031 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
5032 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
5033 else
5034 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
5035
5036 for (gnat_actual = First_Actual (gnat_node);
5037 Present (gnat_actual);
5038 gnat_formal = Next_Formal_With_Extras (gnat_formal),
5039 gnat_actual = Next_Actual (gnat_actual))
5040 /* If we are dealing with a copy-in/copy-out parameter, we must
5041 retrieve its value from the record returned in the call. */
5042 if (!(present_gnu_tree (gnat_formal)
5043 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
5044 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
5045 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))))
5046 && Ekind (gnat_formal) != E_In_Parameter)
5047 {
5048 /* Get the value to assign to this In Out or Out parameter. It is
5049 either the result of the function if there is only a single such
5050 parameter or the appropriate field from the record returned. */
5051 tree gnu_result
5052 = length == 1
5053 ? gnu_call
5054 : build_component_ref (gnu_call, TREE_PURPOSE (gnu_cico_list),
5055 false);
5056
5057 /* If the actual is a conversion, get the inner expression, which
5058 will be the real destination, and convert the result to the
5059 type of the actual parameter. */
5060 tree gnu_actual
5061 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
5062
5063 /* If the result is padded, remove the padding. */
5064 gnu_result = maybe_padded_object (gnu_result);
5065
5066 /* If the actual is a type conversion, the real target object is
5067 denoted by the inner Expression and we need to convert the
5068 result to the associated type.
5069 We also need to convert our gnu assignment target to this type
5070 if the corresponding GNU_NAME was constructed from the GNAT
5071 conversion node and not from the inner Expression. */
5072 if (Nkind (gnat_actual) == N_Type_Conversion)
5073 {
5074 const Node_Id gnat_expr = Expression (gnat_actual);
5075
5076 gigi_checking_assert (!Do_Range_Check (gnat_expr));
5077
5078 gnu_result
5079 = convert_with_check (Etype (gnat_expr), gnu_result,
5080 Do_Overflow_Check (gnat_actual),
5081 Float_Truncate (gnat_actual),
5082 gnat_actual);
5083
5084 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
5085 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
5086 }
5087
5088 /* Unchecked conversions as actuals for Out parameters are not
5089 allowed in user code because they are not variables, but do
5090 occur in front-end expansions. The associated GNU_NAME is
5091 always obtained from the inner expression in such cases. */
5092 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
5093 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
5094 gnu_result,
5095 No_Truncation (gnat_actual));
5096 else
5097 {
5098 gigi_checking_assert (!Do_Range_Check (gnat_actual));
5099
5100 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
5101 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
5102 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
5103 }
5104
5105 get_atomic_access (gnat_actual, &aa_type, &aa_sync);
5106
5107 /* If an outer atomic access is required for an actual parameter,
5108 build the load-modify-store sequence. */
5109 if (aa_type == OUTER_ATOMIC)
5110 gnu_result
5111 = build_load_modify_store (gnu_actual, gnu_result, gnat_node);
5112
5113 /* Or else, if a simple atomic access is required, build the atomic
5114 store. */
5115 else if (aa_type == SIMPLE_ATOMIC)
5116 gnu_result
5117 = build_atomic_store (gnu_actual, gnu_result, aa_sync);
5118
5119 /* Otherwise build a regular assignment. */
5120 else
5121 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
5122 gnu_actual, gnu_result);
5123
5124 if (EXPR_P (gnu_result))
5125 set_expr_location_from_node (gnu_result, gnat_node);
5126 append_to_statement_list (gnu_result, &gnu_stmt_list);
5127 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
5128 gnu_name_list = TREE_CHAIN (gnu_name_list);
5129 }
5130 }
5131
5132 /* If this is a function call, the result is the call expression unless a
5133 target is specified, in which case we copy the result into the target
5134 and return the assignment statement. */
5135 if (function_call)
5136 {
5137 /* If this is a function with copy-in/copy-out parameters, extract the
5138 return value from it and update the return type. */
5139 if (TYPE_CI_CO_LIST (gnu_subprog_type))
5140 {
5141 tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
5142 gnu_call
5143 = build_component_ref (gnu_call, TREE_PURPOSE (gnu_elmt), false);
5144 gnu_result_type = TREE_TYPE (gnu_call);
5145 }
5146
5147 /* If the function returns an unconstrained array or by direct reference,
5148 we have to dereference the pointer. */
5149 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
5150 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
5151 gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
5152
5153 if (gnu_target)
5154 {
5155 Node_Id gnat_parent = Parent (gnat_node);
5156 enum tree_code op_code;
5157
5158 gigi_checking_assert (!Do_Range_Check (gnat_node));
5159
5160 /* ??? If the return type has variable size, then force the return
5161 slot optimization as we would not be able to create a temporary.
5162 That's what has been done historically. */
5163 if (return_type_with_variable_size_p (gnu_result_type))
5164 op_code = INIT_EXPR;
5165 else
5166 op_code = MODIFY_EXPR;
5167
5168 /* Use the required method to move the result to the target. */
5169 if (atomic_access == OUTER_ATOMIC)
5170 gnu_call
5171 = build_load_modify_store (gnu_target, gnu_call, gnat_node);
5172 else if (atomic_access == SIMPLE_ATOMIC)
5173 gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
5174 else
5175 gnu_call
5176 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
5177
5178 if (EXPR_P (gnu_call))
5179 set_expr_location_from_node (gnu_call, gnat_parent);
5180 append_to_statement_list (gnu_call, &gnu_stmt_list);
5181 }
5182 else
5183 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
5184 }
5185
5186 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
5187 parameters, the result is just the call statement. */
5188 else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
5189 append_to_statement_list (gnu_call, &gnu_stmt_list);
5190
5191 /* Finally, add the copy back statements, if any. */
5192 append_to_statement_list (gnu_after_list, &gnu_stmt_list);
5193
5194 if (went_into_elab_proc)
5195 current_function_decl = NULL_TREE;
5196
5197 /* If we have pushed a binding level, pop it and finish up the enclosing
5198 statement group. */
5199 if (pushed_binding_level)
5200 {
5201 add_stmt (gnu_stmt_list);
5202 gnat_poplevel ();
5203 gnu_result = end_stmt_group ();
5204 }
5205
5206 /* Otherwise, retrieve the statement list, if any. */
5207 else if (gnu_stmt_list)
5208 gnu_result = gnu_stmt_list;
5209
5210 /* Otherwise, just return the call expression. */
5211 else
5212 return gnu_call;
5213
5214 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
5215 But first simplify if we have only one statement in the list. */
5216 if (returning_value)
5217 {
5218 tree first = expr_first (gnu_result), last = expr_last (gnu_result);
5219 if (first == last)
5220 gnu_result = first;
5221 gnu_result
5222 = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
5223 }
5224
5225 return gnu_result;
5226 }
5227
5228 /* Subroutine of gnat_to_gnu to translate gnat_node, an
5229 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
5230
5231 static tree
Handled_Sequence_Of_Statements_to_gnu(Node_Id gnat_node)5232 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
5233 {
5234 /* If just annotating, ignore all EH and cleanups. */
5235 const bool gcc_eh
5236 = (!type_annotate_only
5237 && Present (Exception_Handlers (gnat_node))
5238 && Back_End_Exceptions ());
5239 const bool fe_sjlj_eh
5240 = (!type_annotate_only
5241 && Present (Exception_Handlers (gnat_node))
5242 && Exception_Mechanism == Front_End_SJLJ);
5243 const bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
5244 const bool binding_for_block = (at_end || gcc_eh || fe_sjlj_eh);
5245 tree gnu_jmpsave_decl = NULL_TREE;
5246 tree gnu_jmpbuf_decl = NULL_TREE;
5247 tree gnu_inner_block; /* The statement(s) for the block itself. */
5248 tree gnu_result;
5249 tree gnu_expr;
5250 Node_Id gnat_temp;
5251
5252 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
5253 and the front-end has its own SJLJ mechanism. To call the GCC mechanism,
5254 we call add_cleanup, and when we leave the binding, end_stmt_group will
5255 create the TRY_FINALLY_EXPR construct.
5256
5257 ??? The region level calls down there have been specifically put in place
5258 for a ZCX context and currently the order in which things are emitted
5259 (region/handlers) is different from the SJLJ case. Instead of putting
5260 other calls with different conditions at other places for the SJLJ case,
5261 it seems cleaner to reorder things for the SJLJ case and generalize the
5262 condition to make it not ZCX specific.
5263
5264 If there are any exceptions or cleanup processing involved, we need an
5265 outer statement group (for front-end SJLJ) and binding level. */
5266 if (binding_for_block)
5267 {
5268 start_stmt_group ();
5269 gnat_pushlevel ();
5270 }
5271
5272 /* If using fe_sjlj_eh, make the variables for the setjmp buffer and save
5273 area for address of previous buffer. Do this first since we need to have
5274 the setjmp buf known for any decls in this block. */
5275 if (fe_sjlj_eh)
5276 {
5277 gnu_jmpsave_decl
5278 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
5279 jmpbuf_ptr_type,
5280 build_call_n_expr (get_jmpbuf_decl, 0),
5281 false, false, false, false, false, true, false,
5282 NULL, gnat_node);
5283
5284 /* The __builtin_setjmp receivers will immediately reinstall it. Now
5285 because of the unstructured form of EH used by fe_sjlj_eh, there
5286 might be forward edges going to __builtin_setjmp receivers on which
5287 it is uninitialized, although they will never be actually taken. */
5288 TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
5289 gnu_jmpbuf_decl
5290 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
5291 jmpbuf_type,
5292 NULL_TREE,
5293 false, false, false, false, false, true, false,
5294 NULL, gnat_node);
5295
5296 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
5297
5298 /* When we exit this block, restore the saved value. */
5299 add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
5300 Present (End_Label (gnat_node))
5301 ? End_Label (gnat_node) : gnat_node);
5302 }
5303
5304 /* If we are to call a function when exiting this block, add a cleanup
5305 to the binding level we made above. Note that add_cleanup is FIFO
5306 so we must register this cleanup after the EH cleanup just above. */
5307 if (at_end)
5308 {
5309 tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
5310
5311 /* When not optimizing, disable inlining of finalizers as this can
5312 create a more complex CFG in the parent function. */
5313 if (!optimize || optimize_debug)
5314 DECL_DECLARED_INLINE_P (proc_decl) = 0;
5315
5316 /* If there is no end label attached, we use the location of the At_End
5317 procedure because Expand_Cleanup_Actions might reset the location of
5318 the enclosing construct to that of an inner statement. */
5319 add_cleanup (build_call_n_expr (proc_decl, 0),
5320 Present (End_Label (gnat_node))
5321 ? End_Label (gnat_node) : At_End_Proc (gnat_node));
5322 }
5323
5324 /* Now build the tree for the declarations and statements inside this block.
5325 If this is SJLJ, set our jmp_buf as the current buffer. */
5326 start_stmt_group ();
5327
5328 if (fe_sjlj_eh)
5329 {
5330 gnu_expr = build_call_n_expr (set_jmpbuf_decl, 1,
5331 build_unary_op (ADDR_EXPR, NULL_TREE,
5332 gnu_jmpbuf_decl));
5333 set_expr_location_from_node (gnu_expr, gnat_node);
5334 add_stmt (gnu_expr);
5335 }
5336
5337 if (Present (First_Real_Statement (gnat_node)))
5338 process_decls (Statements (gnat_node), Empty,
5339 First_Real_Statement (gnat_node), true, true);
5340
5341 /* Generate code for each statement in the block. */
5342 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
5343 ? First_Real_Statement (gnat_node)
5344 : First (Statements (gnat_node)));
5345 Present (gnat_temp); gnat_temp = Next (gnat_temp))
5346 add_stmt (gnat_to_gnu (gnat_temp));
5347
5348 gnu_inner_block = end_stmt_group ();
5349
5350 /* Now generate code for the two exception models, if either is relevant for
5351 this block. */
5352 if (fe_sjlj_eh)
5353 {
5354 tree *gnu_else_ptr = 0;
5355 tree gnu_handler;
5356
5357 /* Make a binding level for the exception handling declarations and code
5358 and set up gnu_except_ptr_stack for the handlers to use. */
5359 start_stmt_group ();
5360 gnat_pushlevel ();
5361
5362 vec_safe_push (gnu_except_ptr_stack,
5363 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
5364 build_pointer_type (except_type_node),
5365 build_call_n_expr (get_excptr_decl, 0),
5366 false, false, false, false, false,
5367 true, false, NULL, gnat_node));
5368
5369 /* Generate code for each handler. The N_Exception_Handler case does the
5370 real work and returns a COND_EXPR for each handler, which we chain
5371 together here. */
5372 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5373 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
5374 {
5375 gnu_expr = gnat_to_gnu (gnat_temp);
5376
5377 /* If this is the first one, set it as the outer one. Otherwise,
5378 point the "else" part of the previous handler to us. Then point
5379 to our "else" part. */
5380 if (!gnu_else_ptr)
5381 add_stmt (gnu_expr);
5382 else
5383 *gnu_else_ptr = gnu_expr;
5384
5385 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
5386 }
5387
5388 /* If none of the exception handlers did anything, re-raise but do not
5389 defer abortion. */
5390 gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
5391 gnu_except_ptr_stack->last ());
5392 set_expr_location_from_node
5393 (gnu_expr,
5394 Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
5395
5396 if (gnu_else_ptr)
5397 *gnu_else_ptr = gnu_expr;
5398 else
5399 add_stmt (gnu_expr);
5400
5401 /* End the binding level dedicated to the exception handlers and get the
5402 whole statement group. */
5403 gnu_except_ptr_stack->pop ();
5404 gnat_poplevel ();
5405 gnu_handler = end_stmt_group ();
5406
5407 /* If the setjmp returns 1, we restore our incoming longjmp value and
5408 then check the handlers. */
5409 start_stmt_group ();
5410 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1,
5411 gnu_jmpsave_decl),
5412 gnat_node);
5413 add_stmt (gnu_handler);
5414 gnu_handler = end_stmt_group ();
5415
5416 /* This block is now "if (setjmp) ... <handlers> else <block>". */
5417 gnu_result = build3 (COND_EXPR, void_type_node,
5418 (build_call_n_expr
5419 (setjmp_decl, 1,
5420 build_unary_op (ADDR_EXPR, NULL_TREE,
5421 gnu_jmpbuf_decl))),
5422 gnu_handler, gnu_inner_block);
5423 }
5424 else if (gcc_eh)
5425 {
5426 tree gnu_handlers;
5427 location_t locus;
5428
5429 /* First make a block containing the handlers. */
5430 start_stmt_group ();
5431 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5432 Present (gnat_temp);
5433 gnat_temp = Next_Non_Pragma (gnat_temp))
5434 add_stmt (gnat_to_gnu (gnat_temp));
5435 gnu_handlers = end_stmt_group ();
5436
5437 /* Now make the TRY_CATCH_EXPR for the block. */
5438 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
5439 gnu_inner_block, gnu_handlers);
5440 /* Set a location. We need to find a unique location for the dispatching
5441 code, otherwise we can get coverage or debugging issues. Try with
5442 the location of the end label. */
5443 if (Present (End_Label (gnat_node))
5444 && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus))
5445 SET_EXPR_LOCATION (gnu_result, locus);
5446 else
5447 /* Clear column information so that the exception handler of an
5448 implicit transient block does not incorrectly inherit the slocs
5449 of a decision, which would otherwise confuse control flow based
5450 coverage analysis tools. */
5451 set_expr_location_from_node (gnu_result, gnat_node, true);
5452 }
5453 else
5454 gnu_result = gnu_inner_block;
5455
5456 /* Now close our outer block, if we had to make one. */
5457 if (binding_for_block)
5458 {
5459 add_stmt (gnu_result);
5460 gnat_poplevel ();
5461 gnu_result = end_stmt_group ();
5462 }
5463
5464 return gnu_result;
5465 }
5466
5467 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5468 to a GCC tree, which is returned. This is the variant for front-end sjlj
5469 exception handling. */
5470
5471 static tree
Exception_Handler_to_gnu_fe_sjlj(Node_Id gnat_node)5472 Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node)
5473 {
5474 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5475 an "if" statement to select the proper exceptions. For "Others", exclude
5476 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5477 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5478 tree gnu_choice = boolean_false_node;
5479 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
5480 Node_Id gnat_temp;
5481
5482 for (gnat_temp = First (Exception_Choices (gnat_node));
5483 gnat_temp; gnat_temp = Next (gnat_temp))
5484 {
5485 tree this_choice;
5486
5487 if (Nkind (gnat_temp) == N_Others_Choice)
5488 {
5489 if (All_Others (gnat_temp))
5490 this_choice = boolean_true_node;
5491 else
5492 this_choice
5493 = build_binary_op
5494 (EQ_EXPR, boolean_type_node,
5495 convert
5496 (integer_type_node,
5497 build_component_ref
5498 (build_unary_op
5499 (INDIRECT_REF, NULL_TREE,
5500 gnu_except_ptr_stack->last ()),
5501 not_handled_by_others_decl,
5502 false)),
5503 integer_zero_node);
5504 }
5505
5506 else if (Nkind (gnat_temp) == N_Identifier
5507 || Nkind (gnat_temp) == N_Expanded_Name)
5508 {
5509 Entity_Id gnat_ex_id = Entity (gnat_temp);
5510 tree gnu_expr;
5511
5512 /* Exception may be a renaming. Recover original exception which is
5513 the one elaborated and registered. */
5514 if (Present (Renamed_Object (gnat_ex_id)))
5515 gnat_ex_id = Renamed_Object (gnat_ex_id);
5516
5517 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
5518
5519 this_choice
5520 = build_binary_op
5521 (EQ_EXPR, boolean_type_node,
5522 gnu_except_ptr_stack->last (),
5523 convert (TREE_TYPE (gnu_except_ptr_stack->last ()),
5524 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
5525 }
5526 else
5527 gcc_unreachable ();
5528
5529 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
5530 gnu_choice, this_choice);
5531 }
5532
5533 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
5534 }
5535
5536 /* Return true if no statement in GNAT_LIST can alter the control flow. */
5537
5538 static bool
stmt_list_cannot_alter_control_flow_p(List_Id gnat_list)5539 stmt_list_cannot_alter_control_flow_p (List_Id gnat_list)
5540 {
5541 if (No (gnat_list))
5542 return true;
5543
5544 /* This is very conservative, we reject everything except for simple
5545 assignments between identifiers or literals. */
5546 for (Node_Id gnat_node = First (gnat_list);
5547 Present (gnat_node);
5548 gnat_node = Next (gnat_node))
5549 {
5550 if (Nkind (gnat_node) != N_Assignment_Statement)
5551 return false;
5552
5553 if (Nkind (Name (gnat_node)) != N_Identifier)
5554 return false;
5555
5556 Node_Kind nkind = Nkind (Expression (gnat_node));
5557 if (nkind != N_Identifier
5558 && nkind != N_Integer_Literal
5559 && nkind != N_Real_Literal)
5560 return false;
5561 }
5562
5563 return true;
5564 }
5565
5566 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5567 to a GCC tree, which is returned. This is the variant for GCC exception
5568 schemes. */
5569
5570 static tree
Exception_Handler_to_gnu_gcc(Node_Id gnat_node)5571 Exception_Handler_to_gnu_gcc (Node_Id gnat_node)
5572 {
5573 tree gnu_etypes_list = NULL_TREE;
5574
5575 /* We build a TREE_LIST of nodes representing what exception types this
5576 handler can catch, with special cases for others and all others cases.
5577
5578 Each exception type is actually identified by a pointer to the exception
5579 id, or to a dummy object for "others" and "all others". */
5580 for (Node_Id gnat_temp = First (Exception_Choices (gnat_node));
5581 gnat_temp;
5582 gnat_temp = Next (gnat_temp))
5583 {
5584 tree gnu_expr, gnu_etype;
5585
5586 if (Nkind (gnat_temp) == N_Others_Choice)
5587 {
5588 gnu_expr = All_Others (gnat_temp) ? all_others_decl : others_decl;
5589 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5590 }
5591 else if (Nkind (gnat_temp) == N_Identifier
5592 || Nkind (gnat_temp) == N_Expanded_Name)
5593 {
5594 Entity_Id gnat_ex_id = Entity (gnat_temp);
5595
5596 /* Exception may be a renaming. Recover original exception which is
5597 the one elaborated and registered. */
5598 if (Present (Renamed_Object (gnat_ex_id)))
5599 gnat_ex_id = Renamed_Object (gnat_ex_id);
5600
5601 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
5602 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5603 }
5604 else
5605 gcc_unreachable ();
5606
5607 /* The GCC interface expects NULL to be passed for catch all handlers, so
5608 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5609 is integer_zero_node. It would not work, however, because GCC's
5610 notion of "catch all" is stronger than our notion of "others". Until
5611 we correctly use the cleanup interface as well, doing that would
5612 prevent the "all others" handlers from being seen, because nothing
5613 can be caught beyond a catch all from GCC's point of view. */
5614 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
5615 }
5616
5617 start_stmt_group ();
5618 gnat_pushlevel ();
5619
5620 /* Expand a call to the begin_handler hook at the beginning of the
5621 handler, and arrange for a call to the end_handler hook to occur
5622 on every possible exit path. GDB sets a breakpoint in the
5623 begin_handler for catchpoints.
5624
5625 A v1 begin handler saves the cleanup from the exception object,
5626 and marks the exception as in use, so that it will not be
5627 released by other handlers. A v1 end handler restores the
5628 cleanup and releases the exception object, unless it is still
5629 claimed, or the exception is being propagated (reraised).
5630
5631 __builtin_eh_pointer references the exception occurrence being
5632 handled or propagated. Within the handler region, it is the
5633 former, but within the else branch of the EH_ELSE_EXPR, i.e. the
5634 exceptional cleanup path, it is the latter, so we must save the
5635 occurrence being handled early on, so that, should an exception
5636 be (re)raised, we can release the current exception, or figure
5637 out we're not to release it because we're propagating a reraise
5638 thereof.
5639
5640 We use local variables to retrieve the incoming value at handler
5641 entry time (EXPTR), the saved cleanup (EXCLN) and the token
5642 (EXVTK), and reuse them to feed the end_handler hook's argument
5643 at exit. */
5644
5645 /* CODE: void *EXPTR = __builtin_eh_pointer (0); */
5646 tree gnu_current_exc_ptr
5647 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
5648 1, integer_zero_node);
5649 tree exc_ptr
5650 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
5651 ptr_type_node, gnu_current_exc_ptr,
5652 true, false, false, false, false, true, true,
5653 NULL, gnat_node);
5654
5655 tree prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
5656 gnu_incoming_exc_ptr = exc_ptr;
5657
5658 /* begin_handler_decl must not throw, so we can use it as an
5659 initializer for a variable used in cleanups.
5660
5661 CODE: void *EXCLN = __gnat_begin_handler_v1 (EXPTR); */
5662 tree exc_cleanup
5663 = create_var_decl (get_identifier ("EXCLN"), NULL_TREE,
5664 ptr_type_node,
5665 build_call_n_expr (begin_handler_decl, 1,
5666 exc_ptr),
5667 true, false, false, false, false,
5668 true, true, NULL, gnat_node);
5669
5670 /* Declare and initialize the choice parameter, if present. */
5671 if (Present (Choice_Parameter (gnat_node)))
5672 {
5673 tree gnu_param
5674 = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, true);
5675
5676 /* CODE: __gnat_set_exception_parameter (&choice_param, EXPTR); */
5677 add_stmt (build_call_n_expr
5678 (set_exception_parameter_decl, 2,
5679 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param),
5680 gnu_incoming_exc_ptr));
5681 }
5682
5683 /* CODE: <handler proper> */
5684 add_stmt_list (Statements (gnat_node));
5685
5686 tree call = build_call_n_expr (end_handler_decl, 3,
5687 exc_ptr,
5688 exc_cleanup,
5689 null_pointer_node);
5690 /* If the handler can only end by falling off the end, don't bother
5691 with cleanups. */
5692 if (stmt_list_cannot_alter_control_flow_p (Statements (gnat_node)))
5693 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, NULL); */
5694 add_stmt_with_node (call, gnat_node);
5695 /* Otherwise, all of the above is after
5696 CODE: try {
5697
5698 The call above will appear after
5699 CODE: } finally {
5700
5701 And the code below will appear after
5702 CODE: } else {
5703
5704 The else block to a finally block is taken instead of the finally
5705 block when an exception propagates out of the try block. */
5706 else
5707 {
5708 start_stmt_group ();
5709 gnat_pushlevel ();
5710 /* CODE: void *EXPRP = __builtin_eh_handler (0); */
5711 tree prop_ptr
5712 = create_var_decl (get_identifier ("EXPRP"), NULL_TREE,
5713 ptr_type_node,
5714 build_call_expr (builtin_decl_explicit
5715 (BUILT_IN_EH_POINTER),
5716 1, integer_zero_node),
5717 true, false, false, false, false,
5718 true, true, NULL, gnat_node);
5719
5720 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, EXPRP); */
5721 tree ecall = build_call_n_expr (end_handler_decl, 3,
5722 exc_ptr,
5723 exc_cleanup,
5724 prop_ptr);
5725
5726 add_stmt_with_node (ecall, gnat_node);
5727
5728 /* CODE: } */
5729 gnat_poplevel ();
5730 tree eblk = end_stmt_group ();
5731 tree ehls = build2 (EH_ELSE_EXPR, void_type_node, call, eblk);
5732 add_cleanup (ehls, gnat_node);
5733 }
5734
5735 gnat_poplevel ();
5736
5737 gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
5738
5739 return
5740 build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ());
5741 }
5742
5743 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5744
5745 static void
Compilation_Unit_to_gnu(Node_Id gnat_node)5746 Compilation_Unit_to_gnu (Node_Id gnat_node)
5747 {
5748 const Node_Id gnat_unit = Unit (gnat_node);
5749 const bool body_p = (Nkind (gnat_unit) == N_Package_Body
5750 || Nkind (gnat_unit) == N_Subprogram_Body);
5751 const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
5752 Entity_Id gnat_entity;
5753 Node_Id gnat_pragma, gnat_iter;
5754 /* Make the decl for the elaboration procedure. Emit debug info for it, so
5755 that users can break into their elaboration code in debuggers. Kludge:
5756 don't consider it as a definition so that we have a line map for its
5757 body, but no subprogram description in debug info. In addition, don't
5758 qualify it as artificial, even though it is not a user subprogram per se,
5759 in particular for specs. Unlike, say, clones created internally by the
5760 compiler, this subprogram materializes specific user code and flagging it
5761 artificial would take elab code away from gcov's analysis. */
5762 tree gnu_elab_proc_decl
5763 = create_subprog_decl
5764 (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
5765 NULL_TREE, void_ftype, NULL_TREE,
5766 is_default, true, false, false, true, false, NULL, gnat_unit);
5767 struct elab_info *info;
5768
5769 vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
5770 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
5771
5772 /* Initialize the information structure for the function. */
5773 allocate_struct_function (gnu_elab_proc_decl, false);
5774 set_cfun (NULL);
5775
5776 current_function_decl = NULL_TREE;
5777
5778 start_stmt_group ();
5779 gnat_pushlevel ();
5780
5781 /* For a body, first process the spec if there is one. */
5782 if (Nkind (gnat_unit) == N_Package_Body
5783 || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
5784 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
5785
5786 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
5787 {
5788 elaborate_all_entities (gnat_node);
5789
5790 if (Nkind (gnat_unit) == N_Subprogram_Declaration
5791 || Nkind (gnat_unit) == N_Generic_Package_Declaration
5792 || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
5793 return;
5794 }
5795
5796 /* Then process any pragmas and declarations preceding the unit. */
5797 for (gnat_pragma = First (Context_Items (gnat_node));
5798 Present (gnat_pragma);
5799 gnat_pragma = Next (gnat_pragma))
5800 if (Nkind (gnat_pragma) == N_Pragma)
5801 add_stmt (gnat_to_gnu (gnat_pragma));
5802 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
5803 true, true);
5804
5805 /* Process the unit itself. */
5806 add_stmt (gnat_to_gnu (gnat_unit));
5807
5808 /* Generate code for all the inlined subprograms. */
5809 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5810 Present (gnat_entity);
5811 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5812 {
5813 Node_Id gnat_body;
5814
5815 /* Without optimization, process only the required subprograms. */
5816 if (!optimize && !Has_Pragma_Inline_Always (gnat_entity))
5817 continue;
5818
5819 /* The set of inlined subprograms is computed from data recorded early
5820 during expansion and it can be a strict superset of the final set
5821 computed after semantic analysis, for example if a call to such a
5822 subprogram occurs in a pragma Assert and assertions are disabled.
5823 In that case, semantic analysis resets Is_Public to false but the
5824 entry for the subprogram in the inlining tables is stalled. */
5825 if (!Is_Public (gnat_entity))
5826 continue;
5827
5828 gnat_body = Parent (Declaration_Node (gnat_entity));
5829 if (Nkind (gnat_body) != N_Subprogram_Body)
5830 {
5831 /* ??? This happens when only the spec of a package is provided. */
5832 if (No (Corresponding_Body (gnat_body)))
5833 continue;
5834
5835 gnat_body
5836 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5837 }
5838
5839 /* Define the entity first so we set DECL_EXTERNAL. */
5840 gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
5841 add_stmt (gnat_to_gnu (gnat_body));
5842 }
5843
5844 /* Process any pragmas and actions following the unit. */
5845 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
5846 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
5847 finalize_from_limited_with ();
5848
5849 /* Then process the expressions of pragma Compile_Time_{Error|Warning} to
5850 annotate types referenced therein if they have not been annotated. */
5851 for (int i = 0; gnat_compile_time_expr_list.iterate (i, &gnat_iter); i++)
5852 (void) gnat_to_gnu_external (gnat_iter);
5853 gnat_compile_time_expr_list.release ();
5854
5855 /* Save away what we've made so far and finish it up. */
5856 set_current_block_context (gnu_elab_proc_decl);
5857 gnat_poplevel ();
5858 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
5859 set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
5860 gnu_elab_proc_stack->pop ();
5861
5862 /* Record this potential elaboration procedure for later processing. */
5863 info = ggc_alloc<elab_info> ();
5864 info->next = elab_info_list;
5865 info->elab_proc = gnu_elab_proc_decl;
5866 info->gnat_node = gnat_node;
5867 elab_info_list = info;
5868
5869 /* Force the processing for all nodes that remain in the queue. */
5870 process_deferred_decl_context (true);
5871 }
5872
5873 /* Mark COND, a boolean expression, as predicating a call to a noreturn
5874 function, i.e. predict that it is very likely false, and return it.
5875
5876 The compiler will automatically predict the last edge leading to a call
5877 to a noreturn function as very unlikely taken. This function makes it
5878 possible to extend the prediction to predecessors in case the condition
5879 is made up of several short-circuit operators. */
5880
5881 static tree
build_noreturn_cond(tree cond)5882 build_noreturn_cond (tree cond)
5883 {
5884 tree pred_cst = build_int_cst (integer_type_node, PRED_NORETURN);
5885 return
5886 build_call_expr_internal_loc (UNKNOWN_LOCATION, IFN_BUILTIN_EXPECT,
5887 boolean_type_node, 3, cond,
5888 boolean_false_node, pred_cst);
5889 }
5890
5891 /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
5892 range of values, into GNU_LOW and GNU_HIGH bounds. */
5893
5894 static void
Range_to_gnu(Node_Id gnat_range,tree * gnu_low,tree * gnu_high)5895 Range_to_gnu (Node_Id gnat_range, tree *gnu_low, tree *gnu_high)
5896 {
5897 /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
5898 switch (Nkind (gnat_range))
5899 {
5900 case N_Range:
5901 *gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
5902 *gnu_high = gnat_to_gnu (High_Bound (gnat_range));
5903 break;
5904
5905 case N_Expanded_Name:
5906 case N_Identifier:
5907 {
5908 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
5909 tree gnu_range_base_type = get_base_type (gnu_range_type);
5910
5911 *gnu_low
5912 = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
5913 *gnu_high
5914 = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
5915 }
5916 break;
5917
5918 default:
5919 gcc_unreachable ();
5920 }
5921 }
5922
5923 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
5924 to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
5925 we should place the result type. */
5926
5927 static tree
Raise_Error_to_gnu(Node_Id gnat_node,tree * gnu_result_type_p)5928 Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
5929 {
5930 const Node_Kind kind = Nkind (gnat_node);
5931 const Node_Id gnat_cond = Condition (gnat_node);
5932 const int reason = UI_To_Int (Reason (gnat_node));
5933 const bool with_extra_info
5934 = Exception_Extra_Info
5935 && !No_Exception_Handlers_Set ()
5936 && No (get_exception_label (kind));
5937 tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
5938 Node_Id gnat_rcond;
5939
5940 /* The following processing is not required for correctness. Its purpose is
5941 to give more precise error messages and to record some information. */
5942 switch (reason)
5943 {
5944 case CE_Access_Check_Failed:
5945 if (with_extra_info)
5946 gnu_result = build_call_raise_column (reason, gnat_node, kind);
5947 break;
5948
5949 case CE_Index_Check_Failed:
5950 case CE_Range_Check_Failed:
5951 case CE_Invalid_Data:
5952 if (No (gnat_cond) || Nkind (gnat_cond) != N_Op_Not)
5953 break;
5954 gnat_rcond = Right_Opnd (gnat_cond);
5955 if (Nkind (gnat_rcond) == N_In
5956 || Nkind (gnat_rcond) == N_Op_Ge
5957 || Nkind (gnat_rcond) == N_Op_Le)
5958 {
5959 const Node_Id gnat_index = Left_Opnd (gnat_rcond);
5960 const Node_Id gnat_type = Etype (gnat_index);
5961 tree gnu_index = gnat_to_gnu (gnat_index);
5962 tree gnu_type = get_unpadded_type (gnat_type);
5963 tree gnu_low_bound, gnu_high_bound, disp;
5964 struct loop_info_d *loop;
5965 bool neg_p;
5966
5967 switch (Nkind (gnat_rcond))
5968 {
5969 case N_In:
5970 Range_to_gnu (Right_Opnd (gnat_rcond),
5971 &gnu_low_bound, &gnu_high_bound);
5972 break;
5973
5974 case N_Op_Ge:
5975 gnu_low_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
5976 gnu_high_bound = TYPE_MAX_VALUE (gnu_type);
5977 break;
5978
5979 case N_Op_Le:
5980 gnu_low_bound = TYPE_MIN_VALUE (gnu_type);
5981 gnu_high_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
5982 break;
5983
5984 default:
5985 gcc_unreachable ();
5986 }
5987
5988 gnu_type = maybe_character_type (gnu_type);
5989 if (TREE_TYPE (gnu_index) != gnu_type)
5990 {
5991 gnu_low_bound = convert (gnu_type, gnu_low_bound);
5992 gnu_high_bound = convert (gnu_type, gnu_high_bound);
5993 gnu_index = convert (gnu_type, gnu_index);
5994 }
5995
5996 if (with_extra_info
5997 && Known_Esize (gnat_type)
5998 && UI_To_Int (Esize (gnat_type)) <= 32)
5999 gnu_result
6000 = build_call_raise_range (reason, gnat_node, kind, gnu_index,
6001 gnu_low_bound, gnu_high_bound);
6002
6003 /* If optimization is enabled and we are inside a loop, we try to
6004 compute invariant conditions for checks applied to the iteration
6005 variable, i.e. conditions that are independent of the variable
6006 and necessary in order for the checks to fail in the course of
6007 some iteration. If we succeed, we consider an alternative:
6008
6009 1. If loop unswitching is enabled, we prepend these conditions
6010 to the original conditions of the checks. This will make it
6011 possible for the loop unswitching pass to replace the loop
6012 with two loops, one of which has the checks eliminated and
6013 the other has the original checks reinstated, and a prologue
6014 implementing a run-time selection. The former loop will be
6015 for example suitable for vectorization.
6016
6017 2. Otherwise, we instead append the conditions to the original
6018 conditions of the checks. At worse, if the conditions cannot
6019 be evaluated at compile time, they will be evaluated as true
6020 at run time only when the checks have already failed, thus
6021 contributing negatively only to the size of the executable.
6022 But the hope is that these invariant conditions be evaluated
6023 at compile time to false, thus taking away the entire checks
6024 with them. */
6025 if (optimize
6026 && inside_loop_p ()
6027 && (!gnu_low_bound
6028 || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)))
6029 && (!gnu_high_bound
6030 || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)))
6031 && (loop = find_loop_for (gnu_index, &disp, &neg_p)))
6032 {
6033 struct range_check_info_d *rci = ggc_alloc<range_check_info_d> ();
6034 rci->low_bound = gnu_low_bound;
6035 rci->high_bound = gnu_high_bound;
6036 rci->disp = disp;
6037 rci->neg_p = neg_p;
6038 rci->type = gnu_type;
6039 rci->inserted_cond
6040 = build1 (SAVE_EXPR, boolean_type_node, boolean_true_node);
6041 vec_safe_push (loop->checks, rci);
6042 gnu_cond = build_noreturn_cond (gnat_to_gnu (gnat_cond));
6043 if (optimize >= 3)
6044 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
6045 boolean_type_node,
6046 rci->inserted_cond,
6047 gnu_cond);
6048 else
6049 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
6050 boolean_type_node,
6051 gnu_cond,
6052 rci->inserted_cond);
6053 }
6054 }
6055 break;
6056
6057 default:
6058 break;
6059 }
6060
6061 /* The following processing does the real work, but we must nevertheless make
6062 sure not to override the result of the previous processing. */
6063 if (!gnu_result)
6064 gnu_result = build_call_raise (reason, gnat_node, kind);
6065 set_expr_location_from_node (gnu_result, gnat_node);
6066
6067 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
6068
6069 /* If the type is VOID, this is a statement, so we need to generate the code
6070 for the call. Handle a condition, if there is one. */
6071 if (VOID_TYPE_P (*gnu_result_type_p))
6072 {
6073 if (Present (gnat_cond))
6074 {
6075 if (!gnu_cond)
6076 gnu_cond = gnat_to_gnu (gnat_cond);
6077 gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
6078 alloc_stmt_list ());
6079 }
6080 }
6081 else
6082 gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
6083
6084 return gnu_result;
6085 }
6086
6087 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
6088 parameter of a call. */
6089
6090 static bool
lhs_or_actual_p(Node_Id gnat_node)6091 lhs_or_actual_p (Node_Id gnat_node)
6092 {
6093 const Node_Id gnat_parent = Parent (gnat_node);
6094 const Node_Kind kind = Nkind (gnat_parent);
6095
6096 if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
6097 return true;
6098
6099 if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
6100 && Name (gnat_parent) != gnat_node)
6101 return true;
6102
6103 if (kind == N_Parameter_Association)
6104 return true;
6105
6106 return false;
6107 }
6108
6109 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
6110 of an assignment or an actual parameter of a call. */
6111
6112 static bool
present_in_lhs_or_actual_p(Node_Id gnat_node)6113 present_in_lhs_or_actual_p (Node_Id gnat_node)
6114 {
6115 if (lhs_or_actual_p (gnat_node))
6116 return true;
6117
6118 const Node_Kind kind = Nkind (Parent (gnat_node));
6119
6120 if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
6121 && lhs_or_actual_p (Parent (gnat_node)))
6122 return true;
6123
6124 return false;
6125 }
6126
6127 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
6128 as gigi is concerned. This is used to avoid conversions on the LHS. */
6129
6130 static bool
unchecked_conversion_nop(Node_Id gnat_node)6131 unchecked_conversion_nop (Node_Id gnat_node)
6132 {
6133 Entity_Id from_type, to_type;
6134
6135 /* The conversion must be on the LHS of an assignment or an actual parameter
6136 of a call. Otherwise, even if the conversion was essentially a no-op, it
6137 could de facto ensure type consistency and this should be preserved. */
6138 if (!lhs_or_actual_p (gnat_node))
6139 return false;
6140
6141 from_type = Etype (Expression (gnat_node));
6142
6143 /* We're interested in artificial conversions generated by the front-end
6144 to make private types explicit, e.g. in Expand_Assign_Array. */
6145 if (!Is_Private_Type (from_type))
6146 return false;
6147
6148 from_type = Underlying_Type (from_type);
6149 to_type = Etype (gnat_node);
6150
6151 /* The direct conversion to the underlying type is a no-op. */
6152 if (to_type == from_type)
6153 return true;
6154
6155 /* For an array subtype, the conversion to the PAIT is a no-op. */
6156 if (Ekind (from_type) == E_Array_Subtype
6157 && to_type == Packed_Array_Impl_Type (from_type))
6158 return true;
6159
6160 /* For a record subtype, the conversion to the type is a no-op. */
6161 if (Ekind (from_type) == E_Record_Subtype
6162 && to_type == Etype (from_type))
6163 return true;
6164
6165 return false;
6166 }
6167
6168 /* Return true if GNAT_NODE represents a statement. */
6169
6170 static bool
statement_node_p(Node_Id gnat_node)6171 statement_node_p (Node_Id gnat_node)
6172 {
6173 const Node_Kind kind = Nkind (gnat_node);
6174
6175 if (kind == N_Label)
6176 return true;
6177
6178 if (IN (kind, N_Statement_Other_Than_Procedure_Call))
6179 return true;
6180
6181 if (kind == N_Procedure_Call_Statement)
6182 return true;
6183
6184 if (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void)
6185 return true;
6186
6187 return false;
6188 }
6189
6190 /* This function is the driver of the GNAT to GCC tree transformation process.
6191 It is the entry point of the tree transformer. GNAT_NODE is the root of
6192 some GNAT tree. Return the root of the corresponding GCC tree. If this
6193 is an expression, return the GCC equivalent of the expression. If this
6194 is a statement, return the statement or add it to the current statement
6195 group, in which case anything returned is to be interpreted as occurring
6196 after anything added. */
6197
6198 tree
gnat_to_gnu(Node_Id gnat_node)6199 gnat_to_gnu (Node_Id gnat_node)
6200 {
6201 const Node_Kind kind = Nkind (gnat_node);
6202 bool went_into_elab_proc = false;
6203 tree gnu_result = error_mark_node; /* Default to no value. */
6204 tree gnu_result_type = void_type_node;
6205 tree gnu_expr, gnu_lhs, gnu_rhs;
6206 Node_Id gnat_temp;
6207 atomic_acces_t aa_type;
6208 bool aa_sync;
6209
6210 /* Save node number for error message and set location information. */
6211 Current_Error_Node = gnat_node;
6212 Sloc_to_locus (Sloc (gnat_node), &input_location);
6213
6214 /* If we are only annotating types and this node is a statement, return
6215 an empty statement list. */
6216 if (type_annotate_only && statement_node_p (gnat_node))
6217 return alloc_stmt_list ();
6218
6219 /* If we are only annotating types and this node is a subexpression, return
6220 a NULL_EXPR, but filter out nodes appearing in the expressions attached
6221 to packed array implementation types. */
6222 if (type_annotate_only
6223 && IN (kind, N_Subexpr)
6224 && !(((IN (kind, N_Op) && kind != N_Op_Expon)
6225 || kind == N_Type_Conversion)
6226 && Is_Integer_Type (Etype (gnat_node)))
6227 && !(kind == N_Attribute_Reference
6228 && (Get_Attribute_Id (Attribute_Name (gnat_node)) == Attr_Length
6229 || Get_Attribute_Id (Attribute_Name (gnat_node)) == Attr_Size)
6230 && Is_Constrained (Etype (Prefix (gnat_node)))
6231 && !Is_Constr_Subt_For_U_Nominal (Etype (Prefix (gnat_node))))
6232 && kind != N_Expanded_Name
6233 && kind != N_Identifier
6234 && !Compile_Time_Known_Value (gnat_node))
6235 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
6236 build_call_raise (CE_Range_Check_Failed, gnat_node,
6237 N_Raise_Constraint_Error));
6238
6239 if ((statement_node_p (gnat_node) && kind != N_Null_Statement)
6240 || kind == N_Handled_Sequence_Of_Statements
6241 || kind == N_Implicit_Label_Declaration)
6242 {
6243 tree current_elab_proc = get_elaboration_procedure ();
6244
6245 /* If this is a statement and we are at top level, it must be part of
6246 the elaboration procedure, so mark us as being in that procedure. */
6247 if (!current_function_decl)
6248 {
6249 current_function_decl = current_elab_proc;
6250 went_into_elab_proc = true;
6251 }
6252
6253 /* If we are in the elaboration procedure, check if we are violating a
6254 No_Elaboration_Code restriction by having a statement there. Don't
6255 check for a possible No_Elaboration_Code restriction violation on
6256 N_Handled_Sequence_Of_Statements, as we want to signal an error on
6257 every nested real statement instead. This also avoids triggering
6258 spurious errors on dummy (empty) sequences created by the front-end
6259 for package bodies in some cases. */
6260 if (current_function_decl == current_elab_proc
6261 && kind != N_Handled_Sequence_Of_Statements
6262 && kind != N_Implicit_Label_Declaration)
6263 Check_Elaboration_Code_Allowed (gnat_node);
6264 }
6265
6266 switch (kind)
6267 {
6268 /********************************/
6269 /* Chapter 2: Lexical Elements */
6270 /********************************/
6271
6272 case N_Identifier:
6273 case N_Expanded_Name:
6274 case N_Operator_Symbol:
6275 case N_Defining_Identifier:
6276 case N_Defining_Operator_Symbol:
6277 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
6278
6279 /* If atomic access is required on the RHS, build the atomic load. */
6280 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6281 && !present_in_lhs_or_actual_p (gnat_node))
6282 gnu_result = build_atomic_load (gnu_result, aa_sync);
6283 break;
6284
6285 case N_Integer_Literal:
6286 {
6287 tree gnu_type;
6288
6289 /* Get the type of the result, looking inside any padding and
6290 justified modular types. Then get the value in that type. */
6291 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
6292
6293 if (TREE_CODE (gnu_type) == RECORD_TYPE
6294 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
6295 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
6296
6297 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
6298
6299 /* If the result overflows (meaning it doesn't fit in its base type),
6300 abort, unless this is for a named number because that's not fatal.
6301 We would like to check that the value is within the range of the
6302 subtype, but that causes problems with subtypes whose usage will
6303 raise Constraint_Error and also with biased representation. */
6304 if (TREE_OVERFLOW (gnu_result))
6305 {
6306 if (Nkind (Parent (gnat_node)) == N_Number_Declaration)
6307 gnu_result = error_mark_node;
6308 else
6309 gcc_unreachable ();
6310 }
6311 }
6312 break;
6313
6314 case N_Character_Literal:
6315 /* If a Entity is present, it means that this was one of the
6316 literals in a user-defined character type. In that case,
6317 just return the value in the CONST_DECL. Otherwise, use the
6318 character code. In that case, the base type should be an
6319 INTEGER_TYPE, but we won't bother checking for that. */
6320 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6321 if (Present (Entity (gnat_node)))
6322 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
6323 else
6324 gnu_result
6325 = build_int_cst (gnu_result_type,
6326 UI_To_CC (Char_Literal_Value (gnat_node)));
6327 break;
6328
6329 case N_Real_Literal:
6330 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6331
6332 /* If this is of a fixed-point type, the value we want is the value of
6333 the corresponding integer. */
6334 if (Is_Fixed_Point_Type (Underlying_Type (Etype (gnat_node))))
6335 {
6336 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
6337 gnu_result_type);
6338 gcc_assert (!TREE_OVERFLOW (gnu_result));
6339 }
6340
6341 else
6342 {
6343 Ureal ur_realval = Realval (gnat_node);
6344
6345 /* First convert the value to a machine number if it isn't already.
6346 That will force the base to 2 for non-zero values and simplify
6347 the rest of the logic. */
6348 if (!Is_Machine_Number (gnat_node))
6349 ur_realval
6350 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
6351 ur_realval, Round_Even, gnat_node);
6352
6353 if (UR_Is_Zero (ur_realval))
6354 gnu_result = build_real (gnu_result_type, dconst0);
6355 else
6356 {
6357 REAL_VALUE_TYPE tmp;
6358
6359 gnu_result = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
6360
6361 /* The base must be 2 as Machine guarantees this, so we scale
6362 the value, which we know can fit in the mantissa of the type
6363 (hence the use of that type above). */
6364 gcc_assert (Rbase (ur_realval) == 2);
6365 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
6366 - UI_To_Int (Denominator (ur_realval)));
6367 gnu_result = build_real (gnu_result_type, tmp);
6368 }
6369
6370 /* Now see if we need to negate the result. Do it this way to
6371 properly handle -0. */
6372 if (UR_Is_Negative (Realval (gnat_node)))
6373 gnu_result
6374 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
6375 gnu_result);
6376 }
6377
6378 break;
6379
6380 case N_String_Literal:
6381 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6382 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
6383 {
6384 String_Id gnat_string = Strval (gnat_node);
6385 int length = String_Length (gnat_string);
6386 int i;
6387 char *string;
6388 if (length >= ALLOCA_THRESHOLD)
6389 string = XNEWVEC (char, length);
6390 else
6391 string = (char *) alloca (length);
6392
6393 /* Build the string with the characters in the literal. Note
6394 that Ada strings are 1-origin. */
6395 for (i = 0; i < length; i++)
6396 string[i] = Get_String_Char (gnat_string, i + 1);
6397
6398 gnu_result = build_string (length, string);
6399
6400 /* Strings in GCC don't normally have types, but we want
6401 this to not be converted to the array type. */
6402 TREE_TYPE (gnu_result) = gnu_result_type;
6403
6404 if (length >= ALLOCA_THRESHOLD)
6405 free (string);
6406 }
6407 else
6408 {
6409 /* Build a list consisting of each character, then make
6410 the aggregate. */
6411 String_Id gnat_string = Strval (gnat_node);
6412 int length = String_Length (gnat_string);
6413 int i;
6414 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6415 tree gnu_one_node = convert (TREE_TYPE (gnu_idx), integer_one_node);
6416 vec<constructor_elt, va_gc> *gnu_vec;
6417 vec_alloc (gnu_vec, length);
6418
6419 for (i = 0; i < length; i++)
6420 {
6421 tree t = build_int_cst (TREE_TYPE (gnu_result_type),
6422 Get_String_Char (gnat_string, i + 1));
6423
6424 CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
6425 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, gnu_one_node);
6426 }
6427
6428 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
6429 }
6430 break;
6431
6432 case N_Pragma:
6433 gnu_result = Pragma_to_gnu (gnat_node);
6434 break;
6435
6436 /**************************************/
6437 /* Chapter 3: Declarations and Types */
6438 /**************************************/
6439
6440 case N_Subtype_Declaration:
6441 case N_Full_Type_Declaration:
6442 case N_Incomplete_Type_Declaration:
6443 case N_Private_Type_Declaration:
6444 case N_Private_Extension_Declaration:
6445 case N_Task_Type_Declaration:
6446 process_type (Defining_Entity (gnat_node));
6447 gnu_result = alloc_stmt_list ();
6448 break;
6449
6450 case N_Object_Declaration:
6451 case N_Number_Declaration:
6452 case N_Exception_Declaration:
6453 gnat_temp = Defining_Entity (gnat_node);
6454 gnu_result = alloc_stmt_list ();
6455
6456 /* If we are just annotating types and this object has an unconstrained
6457 or task type, don't elaborate it. */
6458 if (type_annotate_only
6459 && (((Is_Array_Type (Etype (gnat_temp))
6460 || Is_Record_Type (Etype (gnat_temp)))
6461 && !Is_Constrained (Etype (gnat_temp)))
6462 || Is_Concurrent_Type (Etype (gnat_temp))))
6463 break;
6464
6465 if (Present (Expression (gnat_node))
6466 && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
6467 && (!type_annotate_only
6468 || Compile_Time_Known_Value (Expression (gnat_node))))
6469 {
6470 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node)));
6471
6472 gnu_expr = gnat_to_gnu (Expression (gnat_node));
6473
6474 /* First deal with erroneous expressions. */
6475 if (TREE_CODE (gnu_expr) == ERROR_MARK)
6476 {
6477 /* If this is a named number for which we cannot manipulate
6478 the value, just skip the declaration altogether. */
6479 if (kind == N_Number_Declaration)
6480 break;
6481 else if (type_annotate_only)
6482 gnu_expr = NULL_TREE;
6483 }
6484
6485 /* Then a special case: we do not want the SLOC of the expression
6486 of the tag to pop up every time it is referenced somewhere. */
6487 else if (EXPR_P (gnu_expr) && Is_Tag (gnat_temp))
6488 SET_EXPR_LOCATION (gnu_expr, UNKNOWN_LOCATION);
6489 }
6490 else
6491 gnu_expr = NULL_TREE;
6492
6493 /* If this is a deferred constant with an address clause, we ignore the
6494 full view since the clause is on the partial view and we cannot have
6495 2 different GCC trees for the object. The only bits of the full view
6496 we will use is the initializer, but it will be directly fetched. */
6497 if (Ekind (gnat_temp) == E_Constant
6498 && Present (Address_Clause (gnat_temp))
6499 && Present (Full_View (gnat_temp)))
6500 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
6501
6502 /* If this object has its elaboration delayed, we must force evaluation
6503 of GNU_EXPR now and save it for the freeze point. Note that we need
6504 not do anything special at the global level since the lifetime of the
6505 temporary is fully contained within the elaboration routine. */
6506 if (Present (Freeze_Node (gnat_temp)))
6507 {
6508 if (gnu_expr)
6509 {
6510 gnu_result = gnat_save_expr (gnu_expr);
6511 save_gnu_tree (gnat_node, gnu_result, true);
6512 }
6513 }
6514 else
6515 gnat_to_gnu_entity (gnat_temp, gnu_expr, true);
6516 break;
6517
6518 case N_Object_Renaming_Declaration:
6519 gnat_temp = Defining_Entity (gnat_node);
6520 gnu_result = alloc_stmt_list ();
6521
6522 /* Don't do anything if this renaming is handled by the front end and it
6523 does not need debug info. Note that we consider renamings don't need
6524 debug info when optimizing: our way to describe them has a
6525 memory/elaboration footprint.
6526
6527 Don't do anything neither if we are just annotating types and this
6528 object has a composite or task type, don't elaborate it. */
6529 if ((!Is_Renaming_Of_Object (gnat_temp)
6530 || (Needs_Debug_Info (gnat_temp)
6531 && !optimize
6532 && can_materialize_object_renaming_p
6533 (Renamed_Object (gnat_temp))))
6534 && ! (type_annotate_only
6535 && (Is_Array_Type (Etype (gnat_temp))
6536 || Is_Record_Type (Etype (gnat_temp))
6537 || Is_Concurrent_Type (Etype (gnat_temp)))))
6538 gnat_to_gnu_entity (gnat_temp,
6539 gnat_to_gnu (Renamed_Object (gnat_temp)),
6540 true);
6541 break;
6542
6543 case N_Exception_Renaming_Declaration:
6544 gnat_temp = Defining_Entity (gnat_node);
6545 gnu_result = alloc_stmt_list ();
6546
6547 if (Present (Renamed_Entity (gnat_temp)))
6548 gnat_to_gnu_entity (gnat_temp,
6549 gnat_to_gnu (Renamed_Entity (gnat_temp)),
6550 true);
6551 break;
6552
6553 case N_Subprogram_Renaming_Declaration:
6554 {
6555 const Node_Id gnat_renaming = Defining_Entity (gnat_node);
6556 const Node_Id gnat_renamed = Renamed_Entity (gnat_renaming);
6557
6558 gnu_result = alloc_stmt_list ();
6559
6560 /* Materializing renamed subprograms will only benefit the debugging
6561 information as they aren't referenced in the generated code. So
6562 skip them when they aren't needed. Avoid doing this if:
6563
6564 - there is a freeze node: in this case the renamed entity is not
6565 elaborated yet,
6566 - the renamed subprogram is intrinsic: it will not be available in
6567 the debugging information (note that both or only one of the
6568 renaming and the renamed subprograms can be intrinsic). */
6569 if (!type_annotate_only
6570 && Needs_Debug_Info (gnat_renaming)
6571 && No (Freeze_Node (gnat_renaming))
6572 && Present (gnat_renamed)
6573 && (Ekind (gnat_renamed) == E_Function
6574 || Ekind (gnat_renamed) == E_Procedure)
6575 && !Is_Intrinsic_Subprogram (gnat_renaming)
6576 && !Is_Intrinsic_Subprogram (gnat_renamed))
6577 gnat_to_gnu_entity (gnat_renaming, gnat_to_gnu (gnat_renamed), true);
6578 break;
6579 }
6580
6581 case N_Implicit_Label_Declaration:
6582 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
6583 gnu_result = alloc_stmt_list ();
6584 break;
6585
6586 case N_Package_Renaming_Declaration:
6587 /* These are fully handled in the front end. */
6588 /* ??? For package renamings, find a way to use GENERIC namespaces so
6589 that we get proper debug information for them. */
6590 gnu_result = alloc_stmt_list ();
6591 break;
6592
6593 /*************************************/
6594 /* Chapter 4: Names and Expressions */
6595 /*************************************/
6596
6597 case N_Explicit_Dereference:
6598 /* Make sure the designated type is complete before dereferencing. */
6599 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6600 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6601 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
6602
6603 /* If atomic access is required on the RHS, build the atomic load. */
6604 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6605 && !present_in_lhs_or_actual_p (gnat_node))
6606 gnu_result = build_atomic_load (gnu_result, aa_sync);
6607 break;
6608
6609 case N_Indexed_Component:
6610 {
6611 tree gnu_array_object = gnat_to_gnu ((Prefix (gnat_node)));
6612 tree gnu_type;
6613 int ndim, i;
6614 Node_Id *gnat_expr_array;
6615
6616 gnu_array_object = maybe_padded_object (gnu_array_object);
6617 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6618
6619 /* Convert vector inputs to their representative array type, to fit
6620 what the code below expects. */
6621 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object)))
6622 {
6623 if (present_in_lhs_or_actual_p (gnat_node))
6624 gnat_mark_addressable (gnu_array_object);
6625 gnu_array_object = maybe_vector_array (gnu_array_object);
6626 }
6627
6628 /* The failure of this assertion will very likely come from a missing
6629 expansion for a packed array access. */
6630 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
6631
6632 /* First compute the number of dimensions of the array, then
6633 fill the expression array, the order depending on whether
6634 this is a Convention_Fortran array or not. */
6635 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
6636 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6637 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
6638 ndim++, gnu_type = TREE_TYPE (gnu_type))
6639 ;
6640
6641 gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
6642
6643 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
6644 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
6645 i >= 0;
6646 i--, gnat_temp = Next (gnat_temp))
6647 gnat_expr_array[i] = gnat_temp;
6648 else
6649 for (i = 0, gnat_temp = First (Expressions (gnat_node));
6650 i < ndim;
6651 i++, gnat_temp = Next (gnat_temp))
6652 gnat_expr_array[i] = gnat_temp;
6653
6654 /* Start with the prefix and build the successive references. */
6655 gnu_result = gnu_array_object;
6656
6657 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
6658 i < ndim;
6659 i++, gnu_type = TREE_TYPE (gnu_type))
6660 {
6661 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
6662 gnat_temp = gnat_expr_array[i];
6663 gnu_expr = maybe_character_value (gnat_to_gnu (gnat_temp));
6664
6665 gnu_result
6666 = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
6667 }
6668
6669 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6670
6671 /* If atomic access is required on the RHS, build the atomic load. */
6672 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6673 && !present_in_lhs_or_actual_p (gnat_node))
6674 gnu_result = build_atomic_load (gnu_result, aa_sync);
6675 }
6676 break;
6677
6678 case N_Slice:
6679 {
6680 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
6681
6682 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6683
6684 gnu_array_object = maybe_padded_object (gnu_array_object);
6685 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6686
6687 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6688 gnu_expr = maybe_character_value (gnu_expr);
6689
6690 /* If this is a slice with non-constant size of an array with constant
6691 size, set the maximum size for the allocation of temporaries. */
6692 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
6693 && TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object))))
6694 TYPE_ARRAY_MAX_SIZE (gnu_result_type)
6695 = TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object));
6696
6697 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
6698 gnu_array_object, gnu_expr);
6699 }
6700 break;
6701
6702 case N_Selected_Component:
6703 {
6704 const Entity_Id gnat_prefix = Prefix (gnat_node);
6705 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
6706 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
6707
6708 gnu_prefix = maybe_padded_object (gnu_prefix);
6709
6710 /* gnat_to_gnu_entity does not save the GNU tree made for renamed
6711 discriminants so avoid making recursive calls on each reference
6712 to them by following the appropriate link directly here. */
6713 if (Ekind (gnat_field) == E_Discriminant)
6714 {
6715 /* For discriminant references in tagged types always substitute
6716 the corresponding discriminant as the actual component. */
6717 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix))))
6718 while (Present (Corresponding_Discriminant (gnat_field)))
6719 gnat_field = Corresponding_Discriminant (gnat_field);
6720
6721 /* For discriminant references in untagged types always substitute
6722 the corresponding stored discriminant. */
6723 else if (Present (Corresponding_Discriminant (gnat_field)))
6724 gnat_field = Original_Record_Component (gnat_field);
6725 }
6726
6727 /* Handle extracting the real or imaginary part of a complex.
6728 The real part is the first field and the imaginary the last. */
6729 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
6730 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
6731 ? REALPART_EXPR : IMAGPART_EXPR,
6732 NULL_TREE, gnu_prefix);
6733 else
6734 {
6735 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
6736
6737 gnu_result
6738 = build_component_ref (gnu_prefix, gnu_field,
6739 (Nkind (Parent (gnat_node))
6740 == N_Attribute_Reference)
6741 && lvalue_required_for_attribute_p
6742 (Parent (gnat_node)));
6743 }
6744
6745 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6746
6747 /* If atomic access is required on the RHS, build the atomic load. */
6748 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6749 && !present_in_lhs_or_actual_p (gnat_node))
6750 gnu_result = build_atomic_load (gnu_result, aa_sync);
6751 }
6752 break;
6753
6754 case N_Attribute_Reference:
6755 {
6756 /* The attribute designator. */
6757 const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
6758
6759 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6760 is a unit, not an object with a GCC equivalent. */
6761 if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
6762 return
6763 create_subprog_decl (create_concat_name
6764 (Entity (Prefix (gnat_node)),
6765 attr == Attr_Elab_Body ? "elabb" : "elabs"),
6766 NULL_TREE, void_ftype, NULL_TREE, is_default,
6767 true, true, true, true, false, NULL,
6768 gnat_node);
6769
6770 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
6771 }
6772 break;
6773
6774 case N_Reference:
6775 /* Like 'Access as far as we are concerned. */
6776 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6777 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6778 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6779 break;
6780
6781 case N_Aggregate:
6782 case N_Extension_Aggregate:
6783 {
6784 tree gnu_aggr_type;
6785
6786 /* Check that this aggregate has not slipped through the cracks. */
6787 gcc_assert (!Expansion_Delayed (gnat_node));
6788
6789 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6790
6791 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
6792 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
6793 gnu_aggr_type
6794 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type)));
6795 else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
6796 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
6797 else
6798 gnu_aggr_type = gnu_result_type;
6799
6800 if (Null_Record_Present (gnat_node))
6801 gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
6802
6803 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
6804 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
6805 gnu_result
6806 = assoc_to_constructor (Etype (gnat_node),
6807 First (Component_Associations (gnat_node)),
6808 gnu_aggr_type);
6809 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
6810 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
6811 gnu_aggr_type);
6812 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
6813 gnu_result
6814 = build_binary_op
6815 (COMPLEX_EXPR, gnu_aggr_type,
6816 gnat_to_gnu (Expression (First
6817 (Component_Associations (gnat_node)))),
6818 gnat_to_gnu (Expression
6819 (Next
6820 (First (Component_Associations (gnat_node))))));
6821 else
6822 gcc_unreachable ();
6823
6824 gnu_result = convert (gnu_result_type, gnu_result);
6825 }
6826 break;
6827
6828 case N_Null:
6829 if (TARGET_VTABLE_USES_DESCRIPTORS
6830 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
6831 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
6832 gnu_result = null_fdesc_node;
6833 else
6834 gnu_result = null_pointer_node;
6835 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6836 break;
6837
6838 case N_Type_Conversion:
6839 case N_Qualified_Expression:
6840 gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
6841 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6842
6843 /* If this is a qualified expression for a tagged type, we mark the type
6844 as used. Because of polymorphism, this might be the only reference to
6845 the tagged type in the program while objects have it as dynamic type.
6846 The debugger needs to see it to display these objects properly. */
6847 if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
6848 used_types_insert (gnu_result_type);
6849
6850 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node)));
6851
6852 gnu_result
6853 = convert_with_check (Etype (gnat_node), gnu_expr,
6854 Do_Overflow_Check (gnat_node),
6855 kind == N_Type_Conversion
6856 && Float_Truncate (gnat_node), gnat_node);
6857 break;
6858
6859 case N_Unchecked_Type_Conversion:
6860 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6861 gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
6862
6863 /* Skip further processing if the conversion is deemed a no-op. */
6864 if (unchecked_conversion_nop (gnat_node))
6865 {
6866 gnu_result = gnu_expr;
6867 gnu_result_type = TREE_TYPE (gnu_result);
6868 break;
6869 }
6870
6871 /* If the result is a pointer type, see if we are improperly
6872 converting to a stricter alignment. */
6873 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
6874 && Is_Access_Type (Etype (gnat_node)))
6875 {
6876 unsigned int align = known_alignment (gnu_expr);
6877 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
6878 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
6879
6880 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
6881 post_error_ne_tree_2
6882 ("?source alignment (^) '< alignment of & (^)",
6883 gnat_node, Designated_Type (Etype (gnat_node)),
6884 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
6885 }
6886
6887 /* If we are converting a descriptor to a function pointer, first
6888 build the pointer. */
6889 if (TARGET_VTABLE_USES_DESCRIPTORS
6890 && TREE_TYPE (gnu_expr) == fdesc_type_node
6891 && POINTER_TYPE_P (gnu_result_type))
6892 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
6893
6894 gnu_result = unchecked_convert (gnu_result_type, gnu_expr,
6895 No_Truncation (gnat_node));
6896 break;
6897
6898 case N_In:
6899 case N_Not_In:
6900 {
6901 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
6902 tree gnu_low, gnu_high;
6903
6904 Range_to_gnu (Right_Opnd (gnat_node), &gnu_low, &gnu_high);
6905 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6906
6907 tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_obj));
6908 if (TREE_TYPE (gnu_obj) != gnu_op_type)
6909 {
6910 gnu_obj = convert (gnu_op_type, gnu_obj);
6911 gnu_low = convert (gnu_op_type, gnu_low);
6912 gnu_high = convert (gnu_op_type, gnu_high);
6913 }
6914
6915 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
6916 ensure that GNU_OBJ is evaluated only once and perform a full range
6917 test. */
6918 if (operand_equal_p (gnu_low, gnu_high, 0))
6919 gnu_result
6920 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
6921 else
6922 {
6923 tree t1, t2;
6924 gnu_obj = gnat_protect_expr (gnu_obj);
6925 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
6926 if (EXPR_P (t1))
6927 set_expr_location_from_node (t1, gnat_node);
6928 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
6929 if (EXPR_P (t2))
6930 set_expr_location_from_node (t2, gnat_node);
6931 gnu_result
6932 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
6933 }
6934
6935 if (kind == N_Not_In)
6936 gnu_result
6937 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
6938 }
6939 break;
6940
6941 case N_Op_Divide:
6942 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6943 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6944 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6945 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
6946 ? RDIV_EXPR
6947 : (Rounded_Result (gnat_node)
6948 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
6949 gnu_result_type, gnu_lhs, gnu_rhs);
6950 break;
6951
6952 case N_Op_Eq:
6953 case N_Op_Ne:
6954 case N_Op_Lt:
6955 case N_Op_Le:
6956 case N_Op_Gt:
6957 case N_Op_Ge:
6958 case N_Op_Add:
6959 case N_Op_Subtract:
6960 case N_Op_Multiply:
6961 case N_Op_Mod:
6962 case N_Op_Rem:
6963 case N_Op_Rotate_Left:
6964 case N_Op_Rotate_Right:
6965 case N_Op_Shift_Left:
6966 case N_Op_Shift_Right:
6967 case N_Op_Shift_Right_Arithmetic:
6968 case N_Op_And:
6969 case N_Op_Or:
6970 case N_Op_Xor:
6971 case N_And_Then:
6972 case N_Or_Else:
6973 {
6974 enum tree_code code = gnu_codes[kind];
6975 bool ignore_lhs_overflow = false;
6976 location_t saved_location = input_location;
6977 tree gnu_type, gnu_max_shift = NULL_TREE;
6978
6979 /* Fix operations set up for boolean types in GNU_CODES above. */
6980 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6981 switch (kind)
6982 {
6983 case N_Op_And:
6984 code = BIT_AND_EXPR;
6985 break;
6986 case N_Op_Or:
6987 code = BIT_IOR_EXPR;
6988 break;
6989 case N_Op_Xor:
6990 code = BIT_XOR_EXPR;
6991 break;
6992 default:
6993 break;
6994 }
6995
6996 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6997 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6998 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
6999
7000 /* If this is a shift, take the count as unsigned since that is what
7001 most machines do and will generate simpler adjustments below. */
7002 if (IN (kind, N_Op_Shift))
7003 {
7004 tree gnu_count_type
7005 = gnat_unsigned_type_for (get_base_type (TREE_TYPE (gnu_rhs)));
7006 gnu_rhs = convert (gnu_count_type, gnu_rhs);
7007 gnu_max_shift
7008 = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type));
7009 }
7010
7011 /* Pending generic support for efficient vector logical operations in
7012 GCC, convert vectors to their representative array type view and
7013 fallthrough. */
7014 gnu_lhs = maybe_vector_array (gnu_lhs);
7015 gnu_rhs = maybe_vector_array (gnu_rhs);
7016
7017 /* If this is a comparison operator, convert any references to an
7018 unconstrained array value into a reference to the actual array. */
7019 if (TREE_CODE_CLASS (code) == tcc_comparison)
7020 {
7021 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
7022 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
7023
7024 tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_lhs));
7025 if (TREE_TYPE (gnu_lhs) != gnu_op_type)
7026 {
7027 gnu_lhs = convert (gnu_op_type, gnu_lhs);
7028 gnu_rhs = convert (gnu_op_type, gnu_rhs);
7029 }
7030 }
7031
7032 /* If this is a shift whose count is not guaranteed to be correct,
7033 we need to adjust the shift count. */
7034 if ((kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
7035 && !Shift_Count_OK (gnat_node))
7036 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, TREE_TYPE (gnu_rhs),
7037 gnu_rhs, gnu_max_shift);
7038 else if (kind == N_Op_Shift_Right_Arithmetic
7039 && !Shift_Count_OK (gnat_node))
7040 gnu_rhs
7041 = build_binary_op (MIN_EXPR, TREE_TYPE (gnu_rhs),
7042 build_binary_op (MINUS_EXPR,
7043 TREE_TYPE (gnu_rhs),
7044 gnu_max_shift,
7045 build_int_cst
7046 (TREE_TYPE (gnu_rhs), 1)),
7047 gnu_rhs);
7048
7049 /* For right shifts, the type says what kind of shift to do,
7050 so we may need to choose a different type. In this case,
7051 we have to ignore integer overflow lest it propagates all
7052 the way down and causes a CE to be explicitly raised. */
7053 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
7054 {
7055 gnu_type = gnat_unsigned_type_for (gnu_type);
7056 ignore_lhs_overflow = true;
7057 }
7058 else if (kind == N_Op_Shift_Right_Arithmetic
7059 && TYPE_UNSIGNED (gnu_type))
7060 {
7061 gnu_type = gnat_signed_type_for (gnu_type);
7062 ignore_lhs_overflow = true;
7063 }
7064
7065 if (gnu_type != gnu_result_type)
7066 {
7067 tree gnu_old_lhs = gnu_lhs;
7068 gnu_lhs = convert (gnu_type, gnu_lhs);
7069 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
7070 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
7071 gnu_rhs = convert (gnu_type, gnu_rhs);
7072 if (gnu_max_shift)
7073 gnu_max_shift = convert (gnu_type, gnu_max_shift);
7074 }
7075
7076 /* For signed integer addition, subtraction and multiplication, do an
7077 overflow check if required. */
7078 if (Do_Overflow_Check (gnat_node)
7079 && (code == PLUS_EXPR || code == MINUS_EXPR || code == MULT_EXPR)
7080 && !TYPE_UNSIGNED (gnu_type)
7081 && !FLOAT_TYPE_P (gnu_type))
7082 gnu_result
7083 = build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs,
7084 gnat_node);
7085 else
7086 {
7087 /* Some operations, e.g. comparisons of arrays, generate complex
7088 trees that need to be annotated while they are being built. */
7089 input_location = saved_location;
7090 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
7091 }
7092
7093 /* If this is a logical shift with the shift count not verified,
7094 we must return zero if it is too large. We cannot compensate
7095 beforehand in this case. */
7096 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
7097 && !Shift_Count_OK (gnat_node))
7098 gnu_result
7099 = build_cond_expr (gnu_type,
7100 build_binary_op (GE_EXPR, boolean_type_node,
7101 gnu_rhs, gnu_max_shift),
7102 build_int_cst (gnu_type, 0),
7103 gnu_result);
7104 }
7105 break;
7106
7107 case N_If_Expression:
7108 {
7109 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
7110 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
7111 tree gnu_false
7112 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
7113
7114 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7115 gnu_result
7116 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
7117 }
7118 break;
7119
7120 case N_Op_Plus:
7121 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
7122 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7123 break;
7124
7125 case N_Op_Not:
7126 /* This case can apply to a boolean or a modular type.
7127 Fall through for a boolean operand since GNU_CODES is set
7128 up to handle this. */
7129 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
7130 {
7131 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
7132 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7133 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
7134 gnu_expr);
7135 break;
7136 }
7137
7138 /* ... fall through ... */
7139
7140 case N_Op_Minus:
7141 case N_Op_Abs:
7142 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
7143 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7144
7145 /* For signed integer negation and absolute value, do an overflow check
7146 if required. */
7147 if (Do_Overflow_Check (gnat_node)
7148 && !TYPE_UNSIGNED (gnu_result_type)
7149 && !FLOAT_TYPE_P (gnu_result_type))
7150 gnu_result
7151 = build_unary_op_trapv (gnu_codes[kind], gnu_result_type, gnu_expr,
7152 gnat_node);
7153 else
7154 gnu_result
7155 = build_unary_op (gnu_codes[kind], gnu_result_type, gnu_expr);
7156 break;
7157
7158 case N_Allocator:
7159 {
7160 tree gnu_type, gnu_init;
7161 bool ignore_init_type;
7162
7163 gnat_temp = Expression (gnat_node);
7164
7165 /* The expression can be either an N_Identifier or an Expanded_Name,
7166 which must represent a type, or a N_Qualified_Expression, which
7167 contains both the type and an initial value for the object. */
7168 if (Nkind (gnat_temp) == N_Identifier
7169 || Nkind (gnat_temp) == N_Expanded_Name)
7170 {
7171 ignore_init_type = false;
7172 gnu_init = NULL_TREE;
7173 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
7174 }
7175
7176 else if (Nkind (gnat_temp) == N_Qualified_Expression)
7177 {
7178 const Entity_Id gnat_desig_type
7179 = Designated_Type (Underlying_Type (Etype (gnat_node)));
7180
7181 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
7182
7183 gnu_init = gnat_to_gnu (Expression (gnat_temp));
7184 gnu_init = maybe_unconstrained_array (gnu_init);
7185
7186 gigi_checking_assert (!Do_Range_Check (Expression (gnat_temp)));
7187
7188 if (Is_Elementary_Type (gnat_desig_type)
7189 || Is_Constrained (gnat_desig_type))
7190 gnu_type = gnat_to_gnu_type (gnat_desig_type);
7191 else
7192 {
7193 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
7194 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
7195 gnu_type = TREE_TYPE (gnu_init);
7196 }
7197
7198 /* See the N_Qualified_Expression case for the rationale. */
7199 if (Is_Tagged_Type (gnat_desig_type))
7200 used_types_insert (gnu_type);
7201
7202 gnu_init = convert (gnu_type, gnu_init);
7203 }
7204 else
7205 gcc_unreachable ();
7206
7207 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7208 return build_allocator (gnu_type, gnu_init, gnu_result_type,
7209 Procedure_To_Call (gnat_node),
7210 Storage_Pool (gnat_node), gnat_node,
7211 ignore_init_type);
7212 }
7213 break;
7214
7215 /**************************/
7216 /* Chapter 5: Statements */
7217 /**************************/
7218
7219 case N_Label:
7220 gnu_result = build1 (LABEL_EXPR, void_type_node,
7221 gnat_to_gnu (Identifier (gnat_node)));
7222 break;
7223
7224 case N_Null_Statement:
7225 /* When not optimizing, turn null statements from source into gotos to
7226 the next statement that the middle-end knows how to preserve. */
7227 if (!optimize && Comes_From_Source (gnat_node))
7228 {
7229 tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
7230 DECL_IGNORED_P (label) = 1;
7231 start_stmt_group ();
7232 stmt = build1 (GOTO_EXPR, void_type_node, label);
7233 set_expr_location_from_node (stmt, gnat_node);
7234 add_stmt (stmt);
7235 stmt = build1 (LABEL_EXPR, void_type_node, label);
7236 set_expr_location_from_node (stmt, gnat_node);
7237 add_stmt (stmt);
7238 gnu_result = end_stmt_group ();
7239 }
7240 else
7241 gnu_result = alloc_stmt_list ();
7242 break;
7243
7244 case N_Assignment_Statement:
7245 /* Get the LHS and RHS of the statement and convert any reference to an
7246 unconstrained array into a reference to the underlying array. */
7247 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
7248
7249 /* If the type has a size that overflows, convert this into raise of
7250 Storage_Error: execution shouldn't have gotten here anyway. */
7251 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
7252 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
7253 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
7254 N_Raise_Storage_Error);
7255 else if (Nkind (Expression (gnat_node)) == N_Function_Call)
7256 {
7257 get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
7258 gnu_result
7259 = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
7260 aa_type, aa_sync);
7261 }
7262 else
7263 {
7264 const Node_Id gnat_expr = Expression (gnat_node);
7265 const Node_Id gnat_inner
7266 = Nkind (gnat_expr) == N_Qualified_Expression
7267 ? Expression (gnat_expr)
7268 : gnat_expr;
7269 const Entity_Id gnat_type
7270 = Underlying_Type (Etype (Name (gnat_node)));
7271 const bool use_memset_p
7272 = Is_Array_Type (gnat_type)
7273 && Nkind (gnat_inner) == N_Aggregate
7274 && Is_Single_Aggregate (gnat_inner);
7275
7276 /* If we use memset, we need to find the innermost expression. */
7277 if (use_memset_p)
7278 {
7279 gnat_temp = gnat_inner;
7280 do {
7281 gnat_temp
7282 = Expression (First (Component_Associations (gnat_temp)));
7283 } while (Nkind (gnat_temp) == N_Aggregate
7284 && Is_Single_Aggregate (gnat_temp));
7285 gnu_rhs = gnat_to_gnu (gnat_temp);
7286 }
7287 else
7288 gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
7289
7290 gigi_checking_assert (!Do_Range_Check (gnat_expr));
7291
7292 get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
7293
7294 /* If an outer atomic access is required on the LHS, build the load-
7295 modify-store sequence. */
7296 if (aa_type == OUTER_ATOMIC)
7297 gnu_result = build_load_modify_store (gnu_lhs, gnu_rhs, gnat_node);
7298
7299 /* Or else, if a simple atomic access is required, build the atomic
7300 store. */
7301 else if (aa_type == SIMPLE_ATOMIC)
7302 gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, aa_sync);
7303
7304 /* Or else, use memset when the conditions are met. This has already
7305 been validated by Aggr_Assignment_OK_For_Backend in the front-end
7306 and the RHS is thus guaranteed to be of the appropriate form. */
7307 else if (use_memset_p)
7308 {
7309 tree value
7310 = real_zerop (gnu_rhs)
7311 ? integer_zero_node
7312 : fold_convert (integer_type_node, gnu_rhs);
7313 tree dest = build_fold_addr_expr (gnu_lhs);
7314 tree t = builtin_decl_explicit (BUILT_IN_MEMSET);
7315 /* Be extra careful not to write too much data. */
7316 tree size;
7317 if (TREE_CODE (gnu_lhs) == COMPONENT_REF)
7318 size = DECL_SIZE_UNIT (TREE_OPERAND (gnu_lhs, 1));
7319 else if (DECL_P (gnu_lhs))
7320 size = DECL_SIZE_UNIT (gnu_lhs);
7321 else
7322 size = TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs));
7323 size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_lhs);
7324 if (TREE_CODE (value) == INTEGER_CST && !integer_zerop (value))
7325 {
7326 tree mask
7327 = build_int_cst (integer_type_node,
7328 ((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1);
7329 value = int_const_binop (BIT_AND_EXPR, value, mask);
7330 }
7331 gnu_result = build_call_expr (t, 3, dest, value, size);
7332 }
7333
7334 /* Otherwise build a regular assignment. */
7335 else
7336 gnu_result
7337 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
7338
7339 /* If the assignment type is a regular array and the two sides are
7340 not completely disjoint, play safe and use memmove. But don't do
7341 it for a bit-packed array as it might not be byte-aligned. */
7342 if (TREE_CODE (gnu_result) == MODIFY_EXPR
7343 && Is_Array_Type (gnat_type)
7344 && !Is_Bit_Packed_Array (gnat_type)
7345 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
7346 {
7347 tree to = TREE_OPERAND (gnu_result, 0);
7348 tree from = TREE_OPERAND (gnu_result, 1);
7349 tree type = TREE_TYPE (from);
7350 tree size
7351 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from);
7352 tree to_ptr = build_fold_addr_expr (to);
7353 tree from_ptr = build_fold_addr_expr (from);
7354 tree t = builtin_decl_explicit (BUILT_IN_MEMMOVE);
7355 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
7356 }
7357 }
7358 break;
7359
7360 case N_If_Statement:
7361 {
7362 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
7363
7364 /* Make the outer COND_EXPR. Avoid non-determinism. */
7365 gnu_result = build3 (COND_EXPR, void_type_node,
7366 gnat_to_gnu (Condition (gnat_node)),
7367 NULL_TREE, NULL_TREE);
7368 COND_EXPR_THEN (gnu_result)
7369 = build_stmt_group (Then_Statements (gnat_node), false);
7370 TREE_SIDE_EFFECTS (gnu_result) = 1;
7371 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
7372
7373 /* Now make a COND_EXPR for each of the "else if" parts. Put each
7374 into the previous "else" part and point to where to put any
7375 outer "else". Also avoid non-determinism. */
7376 if (Present (Elsif_Parts (gnat_node)))
7377 for (gnat_temp = First (Elsif_Parts (gnat_node));
7378 Present (gnat_temp); gnat_temp = Next (gnat_temp))
7379 {
7380 gnu_expr = build3 (COND_EXPR, void_type_node,
7381 gnat_to_gnu (Condition (gnat_temp)),
7382 NULL_TREE, NULL_TREE);
7383 COND_EXPR_THEN (gnu_expr)
7384 = build_stmt_group (Then_Statements (gnat_temp), false);
7385 TREE_SIDE_EFFECTS (gnu_expr) = 1;
7386 set_expr_location_from_node (gnu_expr, gnat_temp);
7387 *gnu_else_ptr = gnu_expr;
7388 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
7389 }
7390
7391 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
7392 }
7393 break;
7394
7395 case N_Case_Statement:
7396 gnu_result = Case_Statement_to_gnu (gnat_node);
7397 break;
7398
7399 case N_Loop_Statement:
7400 gnu_result = Loop_Statement_to_gnu (gnat_node);
7401 break;
7402
7403 case N_Block_Statement:
7404 /* The only way to enter the block is to fall through to it. */
7405 if (stmt_group_may_fallthru ())
7406 {
7407 start_stmt_group ();
7408 gnat_pushlevel ();
7409 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7410 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7411 gnat_poplevel ();
7412 gnu_result = end_stmt_group ();
7413 }
7414 else
7415 gnu_result = alloc_stmt_list ();
7416 break;
7417
7418 case N_Exit_Statement:
7419 gnu_result
7420 = build2 (EXIT_STMT, void_type_node,
7421 (Present (Condition (gnat_node))
7422 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
7423 (Present (Name (gnat_node))
7424 ? get_gnu_tree (Entity (Name (gnat_node)))
7425 : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt)));
7426 break;
7427
7428 case N_Simple_Return_Statement:
7429 {
7430 tree gnu_ret_obj, gnu_ret_val;
7431
7432 /* If the subprogram is a function, we must return the expression. */
7433 if (Present (Expression (gnat_node)))
7434 {
7435 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
7436
7437 /* If this function has copy-in/copy-out parameters parameters and
7438 doesn't return by invisible reference, get the real object for
7439 the return. See Subprogram_Body_to_gnu. */
7440 if (TYPE_CI_CO_LIST (gnu_subprog_type)
7441 && !TREE_ADDRESSABLE (gnu_subprog_type))
7442 gnu_ret_obj = gnu_return_var_stack->last ();
7443 else
7444 gnu_ret_obj = DECL_RESULT (current_function_decl);
7445
7446 /* Get the GCC tree for the expression to be returned. */
7447 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
7448
7449 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7450 self-referential since we want to allocate the fixed size. */
7451 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
7452 && type_is_padding_self_referential
7453 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
7454 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
7455
7456 /* If the function returns by direct reference, return a pointer
7457 to the return value. */
7458 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
7459 || By_Ref (gnat_node))
7460 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
7461
7462 /* Otherwise, if it returns an unconstrained array, we have to
7463 allocate a new version of the result and return it. */
7464 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
7465 {
7466 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
7467
7468 /* And find out whether this is a candidate for Named Return
7469 Value. If so, record it. */
7470 if (optimize
7471 && !optimize_debug
7472 && !TYPE_CI_CO_LIST (gnu_subprog_type))
7473 {
7474 tree ret_val = gnu_ret_val;
7475
7476 /* Strip useless conversions around the return value. */
7477 if (gnat_useless_type_conversion (ret_val))
7478 ret_val = TREE_OPERAND (ret_val, 0);
7479
7480 /* Strip unpadding around the return value. */
7481 if (TREE_CODE (ret_val) == COMPONENT_REF
7482 && TYPE_IS_PADDING_P
7483 (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
7484 ret_val = TREE_OPERAND (ret_val, 0);
7485
7486 /* Now apply the test to the return value. */
7487 if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
7488 {
7489 if (!f_named_ret_val)
7490 f_named_ret_val = BITMAP_GGC_ALLOC ();
7491 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
7492 if (!f_gnat_ret)
7493 f_gnat_ret = gnat_node;
7494 }
7495 }
7496
7497 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
7498 gnu_ret_val,
7499 TREE_TYPE (gnu_ret_obj),
7500 Procedure_To_Call (gnat_node),
7501 Storage_Pool (gnat_node),
7502 gnat_node, false);
7503 }
7504
7505 /* Otherwise, if it returns by invisible reference, dereference
7506 the pointer it is passed using the type of the return value
7507 and build the copy operation manually. This ensures that we
7508 don't copy too much data, for example if the return type is
7509 unconstrained with a maximum size. */
7510 else if (TREE_ADDRESSABLE (gnu_subprog_type))
7511 {
7512 tree gnu_ret_deref
7513 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
7514 gnu_ret_obj);
7515 gnu_result = build2 (INIT_EXPR, void_type_node,
7516 gnu_ret_deref, gnu_ret_val);
7517 add_stmt_with_node (gnu_result, gnat_node);
7518 gnu_ret_val = NULL_TREE;
7519 }
7520 }
7521
7522 else
7523 gnu_ret_obj = gnu_ret_val = NULL_TREE;
7524
7525 /* If we have a return label defined, convert this into a branch to
7526 that label. The return proper will be handled elsewhere. */
7527 if (gnu_return_label_stack->last ())
7528 {
7529 if (gnu_ret_val)
7530 add_stmt_with_node (build_binary_op (MODIFY_EXPR,
7531 NULL_TREE, gnu_ret_obj,
7532 gnu_ret_val),
7533 gnat_node);
7534
7535 gnu_result = build1 (GOTO_EXPR, void_type_node,
7536 gnu_return_label_stack->last ());
7537
7538 /* When not optimizing, make sure the return is preserved. */
7539 if (!optimize && Comes_From_Source (gnat_node))
7540 DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0;
7541 }
7542
7543 /* Otherwise, build a regular return. */
7544 else
7545 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
7546 }
7547 break;
7548
7549 case N_Goto_Statement:
7550 gnu_expr = gnat_to_gnu (Name (gnat_node));
7551 gnu_result = build1 (GOTO_EXPR, void_type_node, gnu_expr);
7552 TREE_USED (gnu_expr) = 1;
7553 break;
7554
7555 /***************************/
7556 /* Chapter 6: Subprograms */
7557 /***************************/
7558
7559 case N_Subprogram_Declaration:
7560 /* Unless there is a freeze node, declare the entity. We consider
7561 this a definition even though we're not generating code for the
7562 subprogram because we will be making the corresponding GCC node.
7563 When there is a freeze node, it is considered the definition of
7564 the subprogram and we do nothing until after it is encountered.
7565 That's an efficiency issue: the types involved in the profile
7566 are far more likely to be frozen between the declaration and
7567 the freeze node than before the declaration, so we save some
7568 updates of the GCC node by waiting until the freeze node.
7569 The counterpart is that we assume that there is no reference
7570 to the subprogram between the declaration and the freeze node
7571 in the expanded code; otherwise, it will be interpreted as an
7572 external reference and very likely give rise to a link failure. */
7573 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7574 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
7575 NULL_TREE, true);
7576 gnu_result = alloc_stmt_list ();
7577 break;
7578
7579 case N_Abstract_Subprogram_Declaration:
7580 /* This subprogram doesn't exist for code generation purposes, but we
7581 have to elaborate the types of any parameters and result, unless
7582 they are imported types (nothing to generate in this case).
7583
7584 The parameter list may contain types with freeze nodes, e.g. not null
7585 subtypes, so the subprogram itself may carry a freeze node, in which
7586 case its elaboration must be deferred. */
7587
7588 /* Process the parameter types first. */
7589 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7590 for (gnat_temp
7591 = First_Formal_With_Extras
7592 (Defining_Entity (Specification (gnat_node)));
7593 Present (gnat_temp);
7594 gnat_temp = Next_Formal_With_Extras (gnat_temp))
7595 if (Is_Itype (Etype (gnat_temp))
7596 && !From_Limited_With (Etype (gnat_temp)))
7597 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
7598
7599 /* Then the result type, set to Standard_Void_Type for procedures. */
7600 {
7601 Entity_Id gnat_temp_type
7602 = Etype (Defining_Entity (Specification (gnat_node)));
7603
7604 if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type))
7605 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, false);
7606 }
7607
7608 gnu_result = alloc_stmt_list ();
7609 break;
7610
7611 case N_Defining_Program_Unit_Name:
7612 /* For a child unit identifier go up a level to get the specification.
7613 We get this when we try to find the spec of a child unit package
7614 that is the compilation unit being compiled. */
7615 gnu_result = gnat_to_gnu (Parent (gnat_node));
7616 break;
7617
7618 case N_Subprogram_Body:
7619 Subprogram_Body_to_gnu (gnat_node);
7620 gnu_result = alloc_stmt_list ();
7621 break;
7622
7623 case N_Function_Call:
7624 case N_Procedure_Call_Statement:
7625 gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
7626 NOT_ATOMIC, false);
7627 break;
7628
7629 /************************/
7630 /* Chapter 7: Packages */
7631 /************************/
7632
7633 case N_Package_Declaration:
7634 gnu_result = gnat_to_gnu (Specification (gnat_node));
7635 break;
7636
7637 case N_Package_Specification:
7638
7639 start_stmt_group ();
7640 process_decls (Visible_Declarations (gnat_node),
7641 Private_Declarations (gnat_node), Empty, true, true);
7642 gnu_result = end_stmt_group ();
7643 break;
7644
7645 case N_Package_Body:
7646
7647 /* If this is the body of a generic package - do nothing. */
7648 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
7649 {
7650 gnu_result = alloc_stmt_list ();
7651 break;
7652 }
7653
7654 start_stmt_group ();
7655 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7656
7657 if (Present (Handled_Statement_Sequence (gnat_node)))
7658 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7659
7660 gnu_result = end_stmt_group ();
7661 break;
7662
7663 /********************************/
7664 /* Chapter 8: Visibility Rules */
7665 /********************************/
7666
7667 case N_Use_Package_Clause:
7668 case N_Use_Type_Clause:
7669 /* Nothing to do here - but these may appear in list of declarations. */
7670 gnu_result = alloc_stmt_list ();
7671 break;
7672
7673 /*********************/
7674 /* Chapter 9: Tasks */
7675 /*********************/
7676
7677 case N_Protected_Type_Declaration:
7678 gnu_result = alloc_stmt_list ();
7679 break;
7680
7681 case N_Single_Task_Declaration:
7682 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
7683 gnu_result = alloc_stmt_list ();
7684 break;
7685
7686 /*********************************************************/
7687 /* Chapter 10: Program Structure and Compilation Issues */
7688 /*********************************************************/
7689
7690 case N_Compilation_Unit:
7691 /* This is not called for the main unit on which gigi is invoked. */
7692 Compilation_Unit_to_gnu (gnat_node);
7693 gnu_result = alloc_stmt_list ();
7694 break;
7695
7696 case N_Subunit:
7697 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
7698 break;
7699
7700 case N_Entry_Body:
7701 case N_Protected_Body:
7702 case N_Task_Body:
7703 /* These nodes should only be present when annotating types. */
7704 gcc_assert (type_annotate_only);
7705 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7706 gnu_result = alloc_stmt_list ();
7707 break;
7708
7709 case N_Subprogram_Body_Stub:
7710 case N_Package_Body_Stub:
7711 case N_Protected_Body_Stub:
7712 case N_Task_Body_Stub:
7713 /* Simply process whatever unit is being inserted. */
7714 if (Present (Library_Unit (gnat_node)))
7715 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
7716 else
7717 {
7718 gcc_assert (type_annotate_only);
7719 gnu_result = alloc_stmt_list ();
7720 }
7721 break;
7722
7723 /***************************/
7724 /* Chapter 11: Exceptions */
7725 /***************************/
7726
7727 case N_Handled_Sequence_Of_Statements:
7728 /* If there is an At_End procedure attached to this node, and the EH
7729 mechanism is front-end, we must have at least a corresponding At_End
7730 handler, unless the No_Exception_Handlers restriction is set. */
7731 gcc_assert (type_annotate_only
7732 || !Front_End_Exceptions ()
7733 || No (At_End_Proc (gnat_node))
7734 || Present (Exception_Handlers (gnat_node))
7735 || No_Exception_Handlers_Set ());
7736
7737 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
7738 break;
7739
7740 case N_Exception_Handler:
7741 if (Back_End_Exceptions ())
7742 gnu_result = Exception_Handler_to_gnu_gcc (gnat_node);
7743 else if (Exception_Mechanism == Front_End_SJLJ)
7744 gnu_result = Exception_Handler_to_gnu_fe_sjlj (gnat_node);
7745 else
7746 gcc_unreachable ();
7747 break;
7748
7749 case N_Raise_Statement:
7750 /* Only for reraise in back-end exceptions mode. */
7751 gcc_assert (No (Name (gnat_node)) && Back_End_Exceptions ());
7752
7753 start_stmt_group ();
7754
7755 add_stmt_with_node (build_call_n_expr (reraise_zcx_decl, 1,
7756 gnu_incoming_exc_ptr),
7757 gnat_node);
7758
7759 gnu_result = end_stmt_group ();
7760 break;
7761
7762 case N_Push_Constraint_Error_Label:
7763 gnu_constraint_error_label_stack.safe_push (Exception_Label (gnat_node));
7764 break;
7765
7766 case N_Push_Storage_Error_Label:
7767 gnu_storage_error_label_stack.safe_push (Exception_Label (gnat_node));
7768 break;
7769
7770 case N_Push_Program_Error_Label:
7771 gnu_program_error_label_stack.safe_push (Exception_Label (gnat_node));
7772 break;
7773
7774 case N_Pop_Constraint_Error_Label:
7775 gnat_temp = gnu_constraint_error_label_stack.pop ();
7776 if (Present (gnat_temp)
7777 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)))
7778 Warn_If_No_Local_Raise (gnat_temp);
7779 break;
7780
7781 case N_Pop_Storage_Error_Label:
7782 gnat_temp = gnu_storage_error_label_stack.pop ();
7783 if (Present (gnat_temp)
7784 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)))
7785 Warn_If_No_Local_Raise (gnat_temp);
7786 break;
7787
7788 case N_Pop_Program_Error_Label:
7789 gnat_temp = gnu_program_error_label_stack.pop ();
7790 if (Present (gnat_temp)
7791 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)))
7792 Warn_If_No_Local_Raise (gnat_temp);
7793 break;
7794
7795 /******************************/
7796 /* Chapter 12: Generic Units */
7797 /******************************/
7798
7799 case N_Generic_Function_Renaming_Declaration:
7800 case N_Generic_Package_Renaming_Declaration:
7801 case N_Generic_Procedure_Renaming_Declaration:
7802 case N_Generic_Package_Declaration:
7803 case N_Generic_Subprogram_Declaration:
7804 case N_Package_Instantiation:
7805 case N_Procedure_Instantiation:
7806 case N_Function_Instantiation:
7807 /* These nodes can appear on a declaration list but there is nothing to
7808 to be done with them. */
7809 gnu_result = alloc_stmt_list ();
7810 break;
7811
7812 /**************************************************/
7813 /* Chapter 13: Representation Clauses and */
7814 /* Implementation-Dependent Features */
7815 /**************************************************/
7816
7817 case N_Attribute_Definition_Clause:
7818 gnu_result = alloc_stmt_list ();
7819
7820 /* The only one we need to deal with is 'Address since, for the others,
7821 the front-end puts the information elsewhere. */
7822 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
7823 break;
7824
7825 /* And we only deal with 'Address if the object has a Freeze node. */
7826 gnat_temp = Entity (Name (gnat_node));
7827 if (Freeze_Node (gnat_temp))
7828 {
7829 tree gnu_address = gnat_to_gnu (Expression (gnat_node)), gnu_temp;
7830
7831 /* Get the value to use as the address and save it as the equivalent
7832 for the object; when it is frozen, gnat_to_gnu_entity will do the
7833 right thing. For a subprogram, put the naked address but build a
7834 meaningfull expression for an object in case its address is taken
7835 before the Freeze node is encountered; this can happen if the type
7836 of the object is limited and it is initialized with the result of
7837 a function call. */
7838 if (Is_Subprogram (gnat_temp))
7839 gnu_temp = gnu_address;
7840 else
7841 {
7842 tree gnu_type = gnat_to_gnu_type (Etype (gnat_temp));
7843 /* Drop atomic and volatile qualifiers for the expression. */
7844 gnu_type = TYPE_MAIN_VARIANT (gnu_type);
7845 gnu_type
7846 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
7847 gnu_address = convert (gnu_type, gnu_address);
7848 gnu_temp
7849 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_address);
7850 }
7851
7852 save_gnu_tree (gnat_temp, gnu_temp, true);
7853 }
7854 break;
7855
7856 case N_Enumeration_Representation_Clause:
7857 case N_Record_Representation_Clause:
7858 case N_At_Clause:
7859 /* We do nothing with these. SEM puts the information elsewhere. */
7860 gnu_result = alloc_stmt_list ();
7861 break;
7862
7863 case N_Code_Statement:
7864 if (!type_annotate_only)
7865 {
7866 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
7867 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
7868 tree gnu_clobbers = NULL_TREE, tail;
7869 bool allows_mem, allows_reg, fake;
7870 int ninputs, noutputs, i;
7871 const char **oconstraints;
7872 const char *constraint;
7873 char *clobber;
7874
7875 /* First retrieve the 3 operand lists built by the front-end. */
7876 Setup_Asm_Outputs (gnat_node);
7877 while (Present (gnat_temp = Asm_Output_Variable ()))
7878 {
7879 tree gnu_value = gnat_to_gnu (gnat_temp);
7880 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7881 (Asm_Output_Constraint ()));
7882
7883 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
7884 Next_Asm_Output ();
7885 }
7886
7887 Setup_Asm_Inputs (gnat_node);
7888 while (Present (gnat_temp = Asm_Input_Value ()))
7889 {
7890 tree gnu_value = gnat_to_gnu (gnat_temp);
7891 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7892 (Asm_Input_Constraint ()));
7893
7894 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
7895 Next_Asm_Input ();
7896 }
7897
7898 Clobber_Setup (gnat_node);
7899 while ((clobber = Clobber_Get_Next ()))
7900 gnu_clobbers
7901 = tree_cons (NULL_TREE,
7902 build_string (strlen (clobber) + 1, clobber),
7903 gnu_clobbers);
7904
7905 /* Then perform some standard checking and processing on the
7906 operands. In particular, mark them addressable if needed. */
7907 gnu_outputs = nreverse (gnu_outputs);
7908 noutputs = list_length (gnu_outputs);
7909 gnu_inputs = nreverse (gnu_inputs);
7910 ninputs = list_length (gnu_inputs);
7911 oconstraints = XALLOCAVEC (const char *, noutputs);
7912
7913 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
7914 {
7915 tree output = TREE_VALUE (tail);
7916 constraint
7917 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7918 oconstraints[i] = constraint;
7919
7920 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
7921 &allows_mem, &allows_reg, &fake))
7922 {
7923 /* If the operand is going to end up in memory,
7924 mark it addressable. Note that we don't test
7925 allows_mem like in the input case below; this
7926 is modeled on the C front-end. */
7927 if (!allows_reg)
7928 {
7929 output = remove_conversions (output, false);
7930 if (TREE_CODE (output) == CONST_DECL
7931 && DECL_CONST_CORRESPONDING_VAR (output))
7932 output = DECL_CONST_CORRESPONDING_VAR (output);
7933 if (!gnat_mark_addressable (output))
7934 output = error_mark_node;
7935 }
7936 }
7937 else
7938 output = error_mark_node;
7939
7940 TREE_VALUE (tail) = output;
7941 }
7942
7943 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
7944 {
7945 tree input = TREE_VALUE (tail);
7946 constraint
7947 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7948
7949 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
7950 0, oconstraints,
7951 &allows_mem, &allows_reg))
7952 {
7953 /* If the operand is going to end up in memory,
7954 mark it addressable. */
7955 if (!allows_reg && allows_mem)
7956 {
7957 input = remove_conversions (input, false);
7958 if (TREE_CODE (input) == CONST_DECL
7959 && DECL_CONST_CORRESPONDING_VAR (input))
7960 input = DECL_CONST_CORRESPONDING_VAR (input);
7961 if (!gnat_mark_addressable (input))
7962 input = error_mark_node;
7963 }
7964 }
7965 else
7966 input = error_mark_node;
7967
7968 TREE_VALUE (tail) = input;
7969 }
7970
7971 gnu_result = build5 (ASM_EXPR, void_type_node,
7972 gnu_template, gnu_outputs,
7973 gnu_inputs, gnu_clobbers, NULL_TREE);
7974 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
7975 }
7976 else
7977 gnu_result = alloc_stmt_list ();
7978
7979 break;
7980
7981 /****************/
7982 /* Added Nodes */
7983 /****************/
7984
7985 /* Markers are created by the ABE mechanism to capture information which
7986 is either unavailable of expensive to recompute. Markers do not have
7987 and runtime semantics, and should be ignored. */
7988
7989 case N_Call_Marker:
7990 case N_Variable_Reference_Marker:
7991 gnu_result = alloc_stmt_list ();
7992 break;
7993
7994 case N_Expression_With_Actions:
7995 /* This construct doesn't define a scope so we don't push a binding
7996 level around the statement list, but we wrap it in a SAVE_EXPR to
7997 protect it from unsharing. Elaborate the expression as part of the
7998 same statement group as the actions so that the type declaration
7999 gets inserted there as well. This ensures that the type elaboration
8000 code is issued past the actions computing values on which it might
8001 depend. */
8002 start_stmt_group ();
8003 add_stmt_list (Actions (gnat_node));
8004 gnu_expr = gnat_to_gnu (Expression (gnat_node));
8005 gnu_result = end_stmt_group ();
8006
8007 gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
8008 TREE_SIDE_EFFECTS (gnu_result) = 1;
8009
8010 gnu_result
8011 = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
8012 gnu_result_type = get_unpadded_type (Etype (gnat_node));
8013 break;
8014
8015 case N_Freeze_Entity:
8016 start_stmt_group ();
8017 process_freeze_entity (gnat_node);
8018 process_decls (Actions (gnat_node), Empty, Empty, true, true);
8019 gnu_result = end_stmt_group ();
8020 break;
8021
8022 case N_Freeze_Generic_Entity:
8023 gnu_result = alloc_stmt_list ();
8024 break;
8025
8026 case N_Itype_Reference:
8027 if (!present_gnu_tree (Itype (gnat_node)))
8028 process_type (Itype (gnat_node));
8029 gnu_result = alloc_stmt_list ();
8030 break;
8031
8032 case N_Free_Statement:
8033 gnat_temp = Expression (gnat_node);
8034
8035 if (!type_annotate_only)
8036 {
8037 tree gnu_ptr, gnu_ptr_type, gnu_obj_type, gnu_actual_obj_type;
8038
8039 const Entity_Id gnat_desig_type
8040 = Designated_Type (Underlying_Type (Etype (gnat_temp)));
8041
8042 /* Make sure the designated type is complete before dereferencing,
8043 in case it is a Taft Amendment type. */
8044 (void) gnat_to_gnu_entity (gnat_desig_type, NULL_TREE, false);
8045
8046 gnu_ptr = gnat_to_gnu (gnat_temp);
8047 gnu_ptr_type = TREE_TYPE (gnu_ptr);
8048
8049 /* If this is a thin pointer, we must first dereference it to create
8050 a fat pointer, then go back below to a thin pointer. The reason
8051 for this is that we need to have a fat pointer someplace in order
8052 to properly compute the size. */
8053 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
8054 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
8055 build_unary_op (INDIRECT_REF, NULL_TREE,
8056 gnu_ptr));
8057
8058 /* If this is a fat pointer, the object must have been allocated with
8059 the template in front of the array. So pass the template address,
8060 and get the total size; do it by converting to a thin pointer. */
8061 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
8062 gnu_ptr
8063 = convert (build_pointer_type
8064 (TYPE_OBJECT_RECORD_TYPE
8065 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
8066 gnu_ptr);
8067
8068 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
8069
8070 /* If this is a thin pointer, the object must have been allocated with
8071 the template in front of the array. So pass the template address,
8072 and get the total size. */
8073 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
8074 gnu_ptr
8075 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
8076 gnu_ptr,
8077 fold_build1 (NEGATE_EXPR, sizetype,
8078 byte_position
8079 (DECL_CHAIN
8080 TYPE_FIELDS ((gnu_obj_type)))));
8081
8082 /* If we have a special dynamic constrained subtype on the node, use
8083 it to compute the size; otherwise, use the designated subtype. */
8084 if (Present (Actual_Designated_Subtype (gnat_node)))
8085 {
8086 gnu_actual_obj_type
8087 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
8088
8089 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
8090 gnu_actual_obj_type
8091 = build_unc_object_type_from_ptr (gnu_ptr_type,
8092 gnu_actual_obj_type,
8093 get_identifier ("DEALLOC"),
8094 false);
8095 }
8096 else
8097 gnu_actual_obj_type = gnu_obj_type;
8098
8099 tree gnu_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
8100 gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_ptr);
8101
8102 gnu_result
8103 = build_call_alloc_dealloc (gnu_ptr, gnu_size, gnu_obj_type,
8104 Procedure_To_Call (gnat_node),
8105 Storage_Pool (gnat_node),
8106 gnat_node);
8107 }
8108 break;
8109
8110 case N_Raise_Constraint_Error:
8111 case N_Raise_Program_Error:
8112 case N_Raise_Storage_Error:
8113 if (type_annotate_only)
8114 gnu_result = alloc_stmt_list ();
8115 else
8116 gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type);
8117 break;
8118
8119 case N_Validate_Unchecked_Conversion:
8120 /* The only validation we currently do on an unchecked conversion is
8121 that of aliasing assumptions. */
8122 if (flag_strict_aliasing)
8123 gnat_validate_uc_list.safe_push (gnat_node);
8124 gnu_result = alloc_stmt_list ();
8125 break;
8126
8127 case N_Function_Specification:
8128 case N_Procedure_Specification:
8129 case N_Op_Concat:
8130 case N_Component_Association:
8131 /* These nodes should only be present when annotating types. */
8132 gcc_assert (type_annotate_only);
8133 gnu_result = alloc_stmt_list ();
8134 break;
8135
8136 default:
8137 /* Other nodes are not supposed to reach here. */
8138 gcc_unreachable ();
8139 }
8140
8141 /* If we pushed the processing of the elaboration routine, pop it back. */
8142 if (went_into_elab_proc)
8143 current_function_decl = NULL_TREE;
8144
8145 /* When not optimizing, turn boolean rvalues B into B != false tests
8146 so that we can put the location information of the reference to B on
8147 the inequality operator for better debug info. */
8148 if (!optimize
8149 && TREE_CODE (gnu_result) != INTEGER_CST
8150 && TREE_CODE (gnu_result) != TYPE_DECL
8151 && (kind == N_Identifier
8152 || kind == N_Expanded_Name
8153 || kind == N_Explicit_Dereference
8154 || kind == N_Indexed_Component
8155 || kind == N_Selected_Component)
8156 && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
8157 && Nkind (Parent (gnat_node)) != N_Attribute_Reference
8158 && Nkind (Parent (gnat_node)) != N_Variant_Part
8159 && !lvalue_required_p (gnat_node, gnu_result_type, false, false))
8160 {
8161 gnu_result
8162 = build_binary_op (NE_EXPR, gnu_result_type,
8163 convert (gnu_result_type, gnu_result),
8164 convert (gnu_result_type, boolean_false_node));
8165 if (TREE_CODE (gnu_result) != INTEGER_CST)
8166 set_gnu_expr_location_from_node (gnu_result, gnat_node);
8167 }
8168
8169 /* Set the location information on the result if it's not a simple name
8170 or something that contains a simple name, for example a tag, because
8171 we don"t want all the references to get the location of the first use.
8172 Note that we may have no result if we tried to build a CALL_EXPR node
8173 to a procedure with no side-effects and optimization is enabled. */
8174 else if (kind != N_Identifier
8175 && !(kind == N_Selected_Component
8176 && Chars (Selector_Name (gnat_node)) == Name_uTag)
8177 && gnu_result
8178 && EXPR_P (gnu_result))
8179 set_gnu_expr_location_from_node (gnu_result, gnat_node);
8180
8181 /* If we're supposed to return something of void_type, it means we have
8182 something we're elaborating for effect, so just return. */
8183 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
8184 return gnu_result;
8185
8186 /* If the result is a constant that overflowed, raise Constraint_Error. */
8187 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
8188 {
8189 post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
8190 gnu_result
8191 = build1 (NULL_EXPR, gnu_result_type,
8192 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
8193 N_Raise_Constraint_Error));
8194 }
8195
8196 /* If the result has side-effects and is of an unconstrained type, protect
8197 the expression in case it will be referenced multiple times, i.e. for
8198 its value and to compute the size of an object. But do it neither for
8199 an object nor a renaming declaration, nor a return statement of a call
8200 to a function that returns an unconstrained record type with default
8201 discriminant, because there is no size to be computed in these cases
8202 and this will create a useless temporary. We must do this before any
8203 conversions. */
8204 if (TREE_SIDE_EFFECTS (gnu_result)
8205 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
8206 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
8207 && !(TREE_CODE (gnu_result) == CALL_EXPR
8208 && type_is_padding_self_referential (TREE_TYPE (gnu_result))
8209 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
8210 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration
8211 || Nkind (Parent (gnat_node)) == N_Simple_Return_Statement)))
8212 gnu_result = gnat_protect_expr (gnu_result);
8213
8214 /* Now convert the result to the result type, unless we are in one of the
8215 following cases:
8216
8217 1. If this is the LHS of an assignment or an actual parameter of a
8218 call, return the result almost unmodified since the RHS will have
8219 to be converted to our type in that case, unless the result type
8220 has a simpler size or for array types because this size might be
8221 changed in-between. Likewise if there is just a no-op unchecked
8222 conversion in-between. Similarly, don't convert integral types
8223 that are the operands of an unchecked conversion since we need
8224 to ignore those conversions (for 'Valid).
8225
8226 2. If we have a label (which doesn't have any well-defined type), a
8227 field or an error, return the result almost unmodified. Similarly,
8228 if the two types are record types with the same name, don't convert.
8229 This will be the case when we are converting from a packable version
8230 of a type to its original type and we need those conversions to be
8231 NOPs in order for assignments into these types to work properly.
8232
8233 3. If the type is void or if we have no result, return error_mark_node
8234 to show we have no result.
8235
8236 4. If this is a call to a function that returns with variable size and
8237 the call is used as the expression in either an object or a renaming
8238 declaration, return the result unmodified because we want to use the
8239 return slot optimization in this case.
8240
8241 5. If this is a reference to an unconstrained array which is used as the
8242 prefix of an attribute reference that requires an lvalue, return the
8243 result unmodified because we want to return the original bounds.
8244
8245 6. Finally, if the type of the result is already correct. */
8246
8247 if (Present (Parent (gnat_node))
8248 && (lhs_or_actual_p (gnat_node)
8249 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
8250 && unchecked_conversion_nop (Parent (gnat_node)))
8251 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
8252 && !AGGREGATE_TYPE_P (gnu_result_type)
8253 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
8254 && !(TYPE_SIZE (gnu_result_type)
8255 && TYPE_SIZE (TREE_TYPE (gnu_result))
8256 && AGGREGATE_TYPE_P (gnu_result_type)
8257 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
8258 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
8259 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
8260 != INTEGER_CST))
8261 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
8262 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
8263 && (CONTAINS_PLACEHOLDER_P
8264 (TYPE_SIZE (TREE_TYPE (gnu_result)))))
8265 || (TREE_CODE (gnu_result_type) == ARRAY_TYPE
8266 && TREE_CODE (TREE_TYPE (gnu_result)) == ARRAY_TYPE))
8267 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
8268 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
8269 {
8270 /* Remove padding only if the inner object is of self-referential
8271 size: in that case it must be an object of unconstrained type
8272 with a default discriminant and we want to avoid copying too
8273 much data. But do not remove it if it is already too small. */
8274 if (type_is_padding_self_referential (TREE_TYPE (gnu_result))
8275 && !(TREE_CODE (gnu_result) == COMPONENT_REF
8276 && DECL_BIT_FIELD (TREE_OPERAND (gnu_result, 1))
8277 && DECL_SIZE (TREE_OPERAND (gnu_result, 1))
8278 != TYPE_SIZE (TREE_TYPE (gnu_result))))
8279 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
8280 gnu_result);
8281 }
8282
8283 else if (TREE_CODE (gnu_result) == LABEL_DECL
8284 || TREE_CODE (gnu_result) == FIELD_DECL
8285 || TREE_CODE (gnu_result) == ERROR_MARK
8286 || (TYPE_NAME (gnu_result_type)
8287 == TYPE_NAME (TREE_TYPE (gnu_result))
8288 && TREE_CODE (gnu_result_type) == RECORD_TYPE
8289 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
8290 {
8291 /* Remove any padding. */
8292 gnu_result = maybe_padded_object (gnu_result);
8293 }
8294
8295 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
8296 gnu_result = error_mark_node;
8297
8298 else if (TREE_CODE (gnu_result) == CALL_EXPR
8299 && Present (Parent (gnat_node))
8300 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
8301 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration)
8302 && return_type_with_variable_size_p (TREE_TYPE (gnu_result)))
8303 ;
8304
8305 else if (TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF
8306 && Present (Parent (gnat_node))
8307 && Nkind (Parent (gnat_node)) == N_Attribute_Reference
8308 && lvalue_required_for_attribute_p (Parent (gnat_node)))
8309 ;
8310
8311 else if (TREE_TYPE (gnu_result) != gnu_result_type)
8312 gnu_result = convert (gnu_result_type, gnu_result);
8313
8314 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
8315 while ((TREE_CODE (gnu_result) == NOP_EXPR
8316 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
8317 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
8318 gnu_result = TREE_OPERAND (gnu_result, 0);
8319
8320 return gnu_result;
8321 }
8322
8323 /* Similar to gnat_to_gnu, but discard any object that might be created in
8324 the course of the translation of GNAT_NODE, which must be an "external"
8325 expression in the sense that it will be elaborated elsewhere. */
8326
8327 tree
gnat_to_gnu_external(Node_Id gnat_node)8328 gnat_to_gnu_external (Node_Id gnat_node)
8329 {
8330 const int save_force_global = force_global;
8331 bool went_into_elab_proc = false;
8332
8333 /* Force the local context and create a fake scope that we zap
8334 at the end so declarations will not be stuck either in the
8335 global varpool or in the current scope. */
8336 if (!current_function_decl)
8337 {
8338 current_function_decl = get_elaboration_procedure ();
8339 went_into_elab_proc = true;
8340 }
8341 force_global = 0;
8342 gnat_pushlevel ();
8343
8344 tree gnu_result = gnat_to_gnu (gnat_node);
8345
8346 gnat_zaplevel ();
8347 force_global = save_force_global;
8348 if (went_into_elab_proc)
8349 current_function_decl = NULL_TREE;
8350
8351 /* Do not import locations from external units. */
8352 if (gnu_result && EXPR_P (gnu_result))
8353 SET_EXPR_LOCATION (gnu_result, UNKNOWN_LOCATION);
8354
8355 return gnu_result;
8356 }
8357
8358 /* Return true if the statement list STMT_LIST is empty. */
8359
8360 static bool
empty_stmt_list_p(tree stmt_list)8361 empty_stmt_list_p (tree stmt_list)
8362 {
8363 tree_stmt_iterator tsi;
8364
8365 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
8366 {
8367 tree stmt = tsi_stmt (tsi);
8368
8369 /* Anything else than an empty STMT_STMT counts as something. */
8370 if (TREE_CODE (stmt) != STMT_STMT || STMT_STMT_STMT (stmt))
8371 return false;
8372 }
8373
8374 return true;
8375 }
8376
8377 /* Record the current code position in GNAT_NODE. */
8378
8379 static void
record_code_position(Node_Id gnat_node)8380 record_code_position (Node_Id gnat_node)
8381 {
8382 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
8383
8384 add_stmt_with_node (stmt_stmt, gnat_node);
8385 save_gnu_tree (gnat_node, stmt_stmt, true);
8386 }
8387
8388 /* Insert the code for GNAT_NODE at the position saved for that node. */
8389
8390 static void
insert_code_for(Node_Id gnat_node)8391 insert_code_for (Node_Id gnat_node)
8392 {
8393 tree code = gnat_to_gnu (gnat_node);
8394
8395 /* It's too late to remove the STMT_STMT itself at this point. */
8396 if (!empty_stmt_list_p (code))
8397 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = code;
8398
8399 save_gnu_tree (gnat_node, NULL_TREE, true);
8400 }
8401
8402 /* Start a new statement group chained to the previous group. */
8403
8404 void
start_stmt_group(void)8405 start_stmt_group (void)
8406 {
8407 struct stmt_group *group = stmt_group_free_list;
8408
8409 /* First see if we can get one from the free list. */
8410 if (group)
8411 stmt_group_free_list = group->previous;
8412 else
8413 group = ggc_alloc<stmt_group> ();
8414
8415 group->previous = current_stmt_group;
8416 group->stmt_list = group->block = group->cleanups = NULL_TREE;
8417 current_stmt_group = group;
8418 }
8419
8420 /* Add GNU_STMT to the current statement group. If it is an expression with
8421 no effects, it is ignored. */
8422
8423 void
add_stmt(tree gnu_stmt)8424 add_stmt (tree gnu_stmt)
8425 {
8426 append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list);
8427 }
8428
8429 /* Similar, but the statement is always added, regardless of side-effects. */
8430
8431 void
add_stmt_force(tree gnu_stmt)8432 add_stmt_force (tree gnu_stmt)
8433 {
8434 append_to_statement_list_force (gnu_stmt, ¤t_stmt_group->stmt_list);
8435 }
8436
8437 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
8438
8439 void
add_stmt_with_node(tree gnu_stmt,Node_Id gnat_node)8440 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
8441 {
8442 if (Present (gnat_node))
8443 set_expr_location_from_node (gnu_stmt, gnat_node);
8444 add_stmt (gnu_stmt);
8445 }
8446
8447 /* Similar, but the statement is always added, regardless of side-effects. */
8448
8449 void
add_stmt_with_node_force(tree gnu_stmt,Node_Id gnat_node)8450 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
8451 {
8452 if (Present (gnat_node))
8453 set_expr_location_from_node (gnu_stmt, gnat_node);
8454 add_stmt_force (gnu_stmt);
8455 }
8456
8457 /* Add a declaration statement for GNU_DECL to the current statement group.
8458 Get the SLOC to be put onto the statement from GNAT_NODE. */
8459
8460 void
add_decl_expr(tree gnu_decl,Node_Id gnat_node)8461 add_decl_expr (tree gnu_decl, Node_Id gnat_node)
8462 {
8463 tree type = TREE_TYPE (gnu_decl);
8464 tree gnu_stmt, gnu_init;
8465
8466 /* If this is a variable that Gigi is to ignore, we may have been given
8467 an ERROR_MARK. So test for it. We also might have been given a
8468 reference for a renaming. So only do something for a decl. Also
8469 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
8470 if (!DECL_P (gnu_decl)
8471 || (TREE_CODE (gnu_decl) == TYPE_DECL
8472 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
8473 return;
8474
8475 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
8476
8477 /* If we are external or global, we don't want to output the DECL_EXPR for
8478 this DECL node since we already have evaluated the expressions in the
8479 sizes and positions as globals and doing it again would be wrong. */
8480 if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ())
8481 {
8482 /* Mark everything as used to prevent node sharing with subprograms.
8483 Note that walk_tree knows how to deal with TYPE_DECL, but neither
8484 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
8485 MARK_VISITED (gnu_stmt);
8486 if (TREE_CODE (gnu_decl) == VAR_DECL
8487 || TREE_CODE (gnu_decl) == CONST_DECL)
8488 {
8489 MARK_VISITED (DECL_SIZE (gnu_decl));
8490 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
8491 MARK_VISITED (DECL_INITIAL (gnu_decl));
8492 }
8493 }
8494 else
8495 add_stmt_with_node (gnu_stmt, gnat_node);
8496
8497 /* Mark our TYPE_ADA_SIZE field now since it will not be gimplified. */
8498 if (TREE_CODE (gnu_decl) == TYPE_DECL
8499 && RECORD_OR_UNION_TYPE_P (type)
8500 && !TYPE_FAT_POINTER_P (type))
8501 MARK_VISITED (TYPE_ADA_SIZE (type));
8502
8503 /* If this is a variable and an initializer is attached to it, it must be
8504 valid for the context. Similar to init_const in create_var_decl. */
8505 if (TREE_CODE (gnu_decl) == VAR_DECL
8506 && (gnu_init = DECL_INITIAL (gnu_decl))
8507 && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
8508 || (TREE_STATIC (gnu_decl)
8509 && !initializer_constant_valid_p (gnu_init,
8510 TREE_TYPE (gnu_init)))))
8511 {
8512 DECL_INITIAL (gnu_decl) = NULL_TREE;
8513 if (TREE_READONLY (gnu_decl))
8514 {
8515 TREE_READONLY (gnu_decl) = 0;
8516 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
8517 }
8518
8519 /* Remove any padding so the assignment is done properly. */
8520 gnu_decl = maybe_padded_object (gnu_decl);
8521
8522 gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init);
8523 add_stmt_with_node (gnu_stmt, gnat_node);
8524 }
8525 }
8526
8527 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
8528
8529 static tree
mark_visited_r(tree * tp,int * walk_subtrees,void * data ATTRIBUTE_UNUSED)8530 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
8531 {
8532 tree t = *tp;
8533
8534 if (TREE_VISITED (t))
8535 *walk_subtrees = 0;
8536
8537 /* Don't mark a dummy type as visited because we want to mark its sizes
8538 and fields once it's filled in. */
8539 else if (!TYPE_IS_DUMMY_P (t))
8540 TREE_VISITED (t) = 1;
8541
8542 /* The test in gimplify_type_sizes is on the main variant. */
8543 if (TYPE_P (t))
8544 TYPE_SIZES_GIMPLIFIED (TYPE_MAIN_VARIANT (t)) = 1;
8545
8546 return NULL_TREE;
8547 }
8548
8549 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8550 sized gimplified. We use this to indicate all variable sizes and
8551 positions in global types may not be shared by any subprogram. */
8552
8553 void
mark_visited(tree t)8554 mark_visited (tree t)
8555 {
8556 walk_tree (&t, mark_visited_r, NULL, NULL);
8557 }
8558
8559 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8560 set its location to that of GNAT_NODE if present, but with column info
8561 cleared so that conditional branches generated as part of the cleanup
8562 code do not interfere with coverage analysis tools. */
8563
8564 static void
add_cleanup(tree gnu_cleanup,Node_Id gnat_node)8565 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
8566 {
8567 if (Present (gnat_node))
8568 set_expr_location_from_node (gnu_cleanup, gnat_node, true);
8569
8570 /* An EH_ELSE_EXPR must be by itself, and that's all we need when we
8571 use it. The assert below makes sure that is so. Should we ever
8572 need more than that, we could combine EH_ELSE_EXPRs, and copy
8573 non-EH_ELSE_EXPR stmts into both cleanup paths of an
8574 EH_ELSE_EXPR. */
8575 if (TREE_CODE (gnu_cleanup) == EH_ELSE_EXPR)
8576 {
8577 gcc_assert (!current_stmt_group->cleanups);
8578 current_stmt_group->cleanups = gnu_cleanup;
8579 }
8580 else
8581 {
8582 gcc_assert (!current_stmt_group->cleanups
8583 || (TREE_CODE (current_stmt_group->cleanups)
8584 != EH_ELSE_EXPR));
8585 append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups);
8586 }
8587 }
8588
8589 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8590
8591 void
set_block_for_group(tree gnu_block)8592 set_block_for_group (tree gnu_block)
8593 {
8594 gcc_assert (!current_stmt_group->block);
8595 current_stmt_group->block = gnu_block;
8596 }
8597
8598 /* Return code corresponding to the current code group. It is normally
8599 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
8600 BLOCK or cleanups were set. */
8601
8602 tree
end_stmt_group(void)8603 end_stmt_group (void)
8604 {
8605 struct stmt_group *group = current_stmt_group;
8606 tree gnu_retval = group->stmt_list;
8607
8608 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
8609 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
8610 make a BIND_EXPR. Note that we nest in that because the cleanup may
8611 reference variables in the block. */
8612 if (!gnu_retval)
8613 gnu_retval = alloc_stmt_list ();
8614
8615 if (group->cleanups)
8616 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
8617 group->cleanups);
8618
8619 if (current_stmt_group->block)
8620 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
8621 gnu_retval, group->block);
8622
8623 /* Remove this group from the stack and add it to the free list. */
8624 current_stmt_group = group->previous;
8625 group->previous = stmt_group_free_list;
8626 stmt_group_free_list = group;
8627
8628 return gnu_retval;
8629 }
8630
8631 /* Return whether the current statement group may fall through. */
8632
8633 static inline bool
stmt_group_may_fallthru(void)8634 stmt_group_may_fallthru (void)
8635 {
8636 if (current_stmt_group->stmt_list)
8637 return block_may_fallthru (current_stmt_group->stmt_list);
8638 else
8639 return true;
8640 }
8641
8642 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
8643 statements.*/
8644
8645 static void
add_stmt_list(List_Id gnat_list)8646 add_stmt_list (List_Id gnat_list)
8647 {
8648 Node_Id gnat_node;
8649
8650 if (Present (gnat_list))
8651 for (gnat_node = First (gnat_list); Present (gnat_node);
8652 gnat_node = Next (gnat_node))
8653 add_stmt (gnat_to_gnu (gnat_node));
8654 }
8655
8656 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
8657 If BINDING_P is true, push and pop a binding level around the list. */
8658
8659 static tree
build_stmt_group(List_Id gnat_list,bool binding_p)8660 build_stmt_group (List_Id gnat_list, bool binding_p)
8661 {
8662 start_stmt_group ();
8663
8664 if (binding_p)
8665 gnat_pushlevel ();
8666
8667 add_stmt_list (gnat_list);
8668
8669 if (binding_p)
8670 gnat_poplevel ();
8671
8672 return end_stmt_group ();
8673 }
8674
8675 /* Generate GIMPLE in place for the expression at *EXPR_P. */
8676
8677 int
gnat_gimplify_expr(tree * expr_p,gimple_seq * pre_p,gimple_seq * post_p ATTRIBUTE_UNUSED)8678 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
8679 gimple_seq *post_p ATTRIBUTE_UNUSED)
8680 {
8681 tree expr = *expr_p;
8682 tree type = TREE_TYPE (expr);
8683 tree op;
8684
8685 if (IS_ADA_STMT (expr))
8686 return gnat_gimplify_stmt (expr_p);
8687
8688 switch (TREE_CODE (expr))
8689 {
8690 case NULL_EXPR:
8691 /* If this is an aggregate type, build a null pointer of the appropriate
8692 type and dereference it. */
8693 if (AGGREGATE_TYPE_P (type)
8694 || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
8695 *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE,
8696 convert (build_pointer_type (type),
8697 integer_zero_node));
8698 /* Otherwise, just make a VAR_DECL. */
8699 else
8700 {
8701 *expr_p = create_tmp_var (type, NULL);
8702 TREE_NO_WARNING (*expr_p) = 1;
8703 }
8704
8705 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
8706 return GS_OK;
8707
8708 case UNCONSTRAINED_ARRAY_REF:
8709 /* We should only do this if we are just elaborating for side-effects,
8710 but we can't know that yet. */
8711 *expr_p = TREE_OPERAND (*expr_p, 0);
8712 return GS_OK;
8713
8714 case ADDR_EXPR:
8715 op = TREE_OPERAND (expr, 0);
8716
8717 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
8718 is put into static memory. We know that it's going to be read-only
8719 given the semantics we have and it must be in static memory when the
8720 reference is in an elaboration procedure. */
8721 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
8722 {
8723 tree addr = build_fold_addr_expr (tree_output_constant_def (op));
8724 *expr_p = fold_convert (type, addr);
8725 return GS_ALL_DONE;
8726 }
8727
8728 /* Replace atomic loads with their first argument. That's necessary
8729 because the gimplifier would create a temporary otherwise. */
8730 if (TREE_SIDE_EFFECTS (op))
8731 while (handled_component_p (op) || CONVERT_EXPR_P (op))
8732 {
8733 tree inner = TREE_OPERAND (op, 0);
8734 if (TREE_CODE (inner) == CALL_EXPR && call_is_atomic_load (inner))
8735 {
8736 tree t = CALL_EXPR_ARG (inner, 0);
8737 if (TREE_CODE (t) == NOP_EXPR)
8738 t = TREE_OPERAND (t, 0);
8739 if (TREE_CODE (t) == ADDR_EXPR)
8740 TREE_OPERAND (op, 0) = TREE_OPERAND (t, 0);
8741 else
8742 TREE_OPERAND (op, 0) = build_fold_indirect_ref (t);
8743 }
8744 else
8745 op = inner;
8746 }
8747
8748 return GS_UNHANDLED;
8749
8750 case VIEW_CONVERT_EXPR:
8751 op = TREE_OPERAND (expr, 0);
8752
8753 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
8754 type to a scalar one, explicitly create the local temporary. That's
8755 required if the type is passed by reference. */
8756 if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
8757 && AGGREGATE_TYPE_P (TREE_TYPE (op))
8758 && !AGGREGATE_TYPE_P (type))
8759 {
8760 tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
8761 gimple_add_tmp_var (new_var);
8762
8763 mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
8764 gimplify_and_add (mod, pre_p);
8765
8766 TREE_OPERAND (expr, 0) = new_var;
8767 return GS_OK;
8768 }
8769
8770 return GS_UNHANDLED;
8771
8772 case DECL_EXPR:
8773 op = DECL_EXPR_DECL (expr);
8774
8775 /* The expressions for the RM bounds must be gimplified to ensure that
8776 they are properly elaborated. See gimplify_decl_expr. */
8777 if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
8778 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
8779 switch (TREE_CODE (TREE_TYPE (op)))
8780 {
8781 case INTEGER_TYPE:
8782 case ENUMERAL_TYPE:
8783 case BOOLEAN_TYPE:
8784 case REAL_TYPE:
8785 {
8786 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
8787
8788 val = TYPE_RM_MIN_VALUE (type);
8789 if (val)
8790 {
8791 gimplify_one_sizepos (&val, pre_p);
8792 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8793 SET_TYPE_RM_MIN_VALUE (t, val);
8794 }
8795
8796 val = TYPE_RM_MAX_VALUE (type);
8797 if (val)
8798 {
8799 gimplify_one_sizepos (&val, pre_p);
8800 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8801 SET_TYPE_RM_MAX_VALUE (t, val);
8802 }
8803
8804 }
8805 break;
8806
8807 default:
8808 break;
8809 }
8810
8811 /* ... fall through ... */
8812
8813 default:
8814 return GS_UNHANDLED;
8815 }
8816 }
8817
8818 /* Generate GIMPLE in place for the statement at *STMT_P. */
8819
8820 static enum gimplify_status
gnat_gimplify_stmt(tree * stmt_p)8821 gnat_gimplify_stmt (tree *stmt_p)
8822 {
8823 tree stmt = *stmt_p;
8824
8825 switch (TREE_CODE (stmt))
8826 {
8827 case STMT_STMT:
8828 *stmt_p = STMT_STMT_STMT (stmt);
8829 return GS_OK;
8830
8831 case LOOP_STMT:
8832 {
8833 tree gnu_start_label = create_artificial_label (input_location);
8834 tree gnu_cond = LOOP_STMT_COND (stmt);
8835 tree gnu_update = LOOP_STMT_UPDATE (stmt);
8836 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
8837
8838 /* Build the condition expression from the test, if any. */
8839 if (gnu_cond)
8840 {
8841 /* Deal with the optimization hints. */
8842 if (LOOP_STMT_IVDEP (stmt))
8843 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8844 build_int_cst (integer_type_node,
8845 annot_expr_ivdep_kind),
8846 integer_zero_node);
8847 if (LOOP_STMT_NO_UNROLL (stmt))
8848 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8849 build_int_cst (integer_type_node,
8850 annot_expr_unroll_kind),
8851 integer_one_node);
8852 if (LOOP_STMT_UNROLL (stmt))
8853 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8854 build_int_cst (integer_type_node,
8855 annot_expr_unroll_kind),
8856 build_int_cst (NULL_TREE, USHRT_MAX));
8857 if (LOOP_STMT_NO_VECTOR (stmt))
8858 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8859 build_int_cst (integer_type_node,
8860 annot_expr_no_vector_kind),
8861 integer_zero_node);
8862 if (LOOP_STMT_VECTOR (stmt))
8863 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8864 build_int_cst (integer_type_node,
8865 annot_expr_vector_kind),
8866 integer_zero_node);
8867
8868 gnu_cond
8869 = build3 (COND_EXPR, void_type_node, gnu_cond, NULL_TREE,
8870 build1 (GOTO_EXPR, void_type_node, gnu_end_label));
8871 }
8872
8873 /* Set to emit the statements of the loop. */
8874 *stmt_p = NULL_TREE;
8875
8876 /* We first emit the start label and then a conditional jump to the
8877 end label if there's a top condition, then the update if it's at
8878 the top, then the body of the loop, then a conditional jump to
8879 the end label if there's a bottom condition, then the update if
8880 it's at the bottom, and finally a jump to the start label and the
8881 definition of the end label. */
8882 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
8883 gnu_start_label),
8884 stmt_p);
8885
8886 if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
8887 append_to_statement_list (gnu_cond, stmt_p);
8888
8889 if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
8890 append_to_statement_list (gnu_update, stmt_p);
8891
8892 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
8893
8894 if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
8895 append_to_statement_list (gnu_cond, stmt_p);
8896
8897 if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
8898 append_to_statement_list (gnu_update, stmt_p);
8899
8900 tree t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
8901 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
8902 append_to_statement_list (t, stmt_p);
8903
8904 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
8905 gnu_end_label),
8906 stmt_p);
8907 return GS_OK;
8908 }
8909
8910 case EXIT_STMT:
8911 /* Build a statement to jump to the corresponding end label, then
8912 see if it needs to be conditional. */
8913 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
8914 if (EXIT_STMT_COND (stmt))
8915 *stmt_p = build3 (COND_EXPR, void_type_node,
8916 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
8917 return GS_OK;
8918
8919 default:
8920 gcc_unreachable ();
8921 }
8922 }
8923
8924 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
8925
8926 This routine is exclusively called in type_annotate mode, to compute DDA
8927 information for types in withed units, for ASIS use. */
8928
8929 static void
elaborate_all_entities_for_package(Entity_Id gnat_package)8930 elaborate_all_entities_for_package (Entity_Id gnat_package)
8931 {
8932 Entity_Id gnat_entity;
8933
8934 for (gnat_entity = First_Entity (gnat_package);
8935 Present (gnat_entity);
8936 gnat_entity = Next_Entity (gnat_entity))
8937 {
8938 const Entity_Kind kind = Ekind (gnat_entity);
8939
8940 /* We are interested only in entities visible from the main unit. */
8941 if (!Is_Public (gnat_entity))
8942 continue;
8943
8944 /* Skip stuff internal to the compiler. */
8945 if (Convention (gnat_entity) == Convention_Intrinsic)
8946 continue;
8947 if (kind == E_Operator)
8948 continue;
8949 if (IN (kind, Subprogram_Kind)
8950 && (Present (Alias (gnat_entity))
8951 || Is_Intrinsic_Subprogram (gnat_entity)))
8952 continue;
8953 if (Is_Itype (gnat_entity))
8954 continue;
8955
8956 /* Skip named numbers. */
8957 if (IN (kind, Named_Kind))
8958 continue;
8959
8960 /* Skip generic declarations. */
8961 if (IN (kind, Generic_Unit_Kind))
8962 continue;
8963
8964 /* Skip formal objects. */
8965 if (IN (kind, Formal_Object_Kind))
8966 continue;
8967
8968 /* Skip package bodies. */
8969 if (kind == E_Package_Body)
8970 continue;
8971
8972 /* Skip limited views that point back to the main unit. */
8973 if (IN (kind, Incomplete_Kind)
8974 && From_Limited_With (gnat_entity)
8975 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity)))
8976 continue;
8977
8978 /* Skip types that aren't frozen. */
8979 if (IN (kind, Type_Kind) && !Is_Frozen (gnat_entity))
8980 continue;
8981
8982 /* Recurse on real packages that aren't in the main unit. */
8983 if (kind == E_Package)
8984 {
8985 if (No (Renamed_Entity (gnat_entity))
8986 && !In_Extended_Main_Code_Unit (gnat_entity))
8987 elaborate_all_entities_for_package (gnat_entity);
8988 }
8989 else
8990 gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
8991 }
8992 }
8993
8994 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
8995 Operate recursively but check that we aren't elaborating something more
8996 than once.
8997
8998 This routine is exclusively called in type_annotate mode, to compute DDA
8999 information for types in withed units, for ASIS use. */
9000
9001 static void
elaborate_all_entities(Node_Id gnat_node)9002 elaborate_all_entities (Node_Id gnat_node)
9003 {
9004 Entity_Id gnat_with_clause;
9005
9006 /* Process each unit only once. As we trace the context of all relevant
9007 units transitively, including generic bodies, we may encounter the
9008 same generic unit repeatedly. */
9009 if (!present_gnu_tree (gnat_node))
9010 save_gnu_tree (gnat_node, integer_zero_node, true);
9011
9012 /* Save entities in all context units. A body may have an implicit_with
9013 on its own spec, if the context includes a child unit, so don't save
9014 the spec twice. */
9015 for (gnat_with_clause = First (Context_Items (gnat_node));
9016 Present (gnat_with_clause);
9017 gnat_with_clause = Next (gnat_with_clause))
9018 if (Nkind (gnat_with_clause) == N_With_Clause
9019 && !present_gnu_tree (Library_Unit (gnat_with_clause))
9020 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
9021 {
9022 Node_Id gnat_unit = Library_Unit (gnat_with_clause);
9023 Entity_Id gnat_entity = Entity (Name (gnat_with_clause));
9024
9025 elaborate_all_entities (gnat_unit);
9026
9027 if (Ekind (gnat_entity) == E_Package
9028 && No (Renamed_Entity (gnat_entity)))
9029 elaborate_all_entities_for_package (gnat_entity);
9030
9031 else if (Ekind (gnat_entity) == E_Generic_Package)
9032 {
9033 Node_Id gnat_body = Corresponding_Body (Unit (gnat_unit));
9034
9035 /* Retrieve compilation unit node of generic body. */
9036 while (Present (gnat_body)
9037 && Nkind (gnat_body) != N_Compilation_Unit)
9038 gnat_body = Parent (gnat_body);
9039
9040 /* If body is available, elaborate its context. */
9041 if (Present (gnat_body))
9042 elaborate_all_entities (gnat_body);
9043 }
9044 }
9045
9046 if (Nkind (Unit (gnat_node)) == N_Package_Body)
9047 elaborate_all_entities (Library_Unit (gnat_node));
9048 }
9049
9050 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
9051
9052 static void
process_freeze_entity(Node_Id gnat_node)9053 process_freeze_entity (Node_Id gnat_node)
9054 {
9055 const Entity_Id gnat_entity = Entity (gnat_node);
9056 const Entity_Kind kind = Ekind (gnat_entity);
9057 tree gnu_old, gnu_new;
9058
9059 /* If this is a package, generate code for the package body, if any. */
9060 if (kind == E_Package)
9061 {
9062 const Node_Id gnat_decl = Parent (Declaration_Node (gnat_entity));
9063 if (Present (Corresponding_Body (gnat_decl)))
9064 insert_code_for (Parent (Corresponding_Body (gnat_decl)));
9065 return;
9066 }
9067
9068 /* Don't do anything for class-wide types as they are always transformed
9069 into their root type. */
9070 if (kind == E_Class_Wide_Type)
9071 return;
9072
9073 /* Check for an old definition if this isn't an object with address clause,
9074 since the saved GCC tree is the address expression in that case. */
9075 gnu_old
9076 = present_gnu_tree (gnat_entity) && No (Address_Clause (gnat_entity))
9077 ? get_gnu_tree (gnat_entity) : NULL_TREE;
9078
9079 /* Don't do anything for subprograms that may have been elaborated before
9080 their freeze nodes. This can happen, for example, because of an inner
9081 call in an instance body or because of previous compilation of a spec
9082 for inlining purposes. */
9083 if (gnu_old
9084 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
9085 && (kind == E_Function || kind == E_Procedure))
9086 || (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_old))
9087 && kind == E_Subprogram_Type)))
9088 return;
9089
9090 /* If we have a non-dummy type old tree, we have nothing to do, except for
9091 aborting, since this node was never delayed as it should have been. We
9092 let this happen for concurrent types and their Corresponding_Record_Type,
9093 however, because each might legitimately be elaborated before its own
9094 freeze node, e.g. while processing the other. */
9095 if (gnu_old
9096 && !(TREE_CODE (gnu_old) == TYPE_DECL
9097 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
9098 {
9099 gcc_assert (Is_Concurrent_Type (gnat_entity)
9100 || (Is_Record_Type (gnat_entity)
9101 && Is_Concurrent_Record_Type (gnat_entity)));
9102 return;
9103 }
9104
9105 /* Reset the saved tree, if any, and elaborate the object or type for real.
9106 If there is a full view, elaborate it and use the result. And, if this
9107 is the root type of a class-wide type, reuse it for the latter. */
9108 if (gnu_old)
9109 {
9110 save_gnu_tree (gnat_entity, NULL_TREE, false);
9111
9112 if (Is_Incomplete_Or_Private_Type (gnat_entity)
9113 && Present (Full_View (gnat_entity)))
9114 {
9115 Entity_Id full_view = Full_View (gnat_entity);
9116
9117 save_gnu_tree (full_view, NULL_TREE, false);
9118
9119 if (Is_Private_Type (full_view)
9120 && Present (Underlying_Full_View (full_view)))
9121 {
9122 full_view = Underlying_Full_View (full_view);
9123 save_gnu_tree (full_view, NULL_TREE, false);
9124 }
9125 }
9126
9127 if (Is_Type (gnat_entity)
9128 && Present (Class_Wide_Type (gnat_entity))
9129 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
9130 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
9131 }
9132
9133 if (Is_Incomplete_Or_Private_Type (gnat_entity)
9134 && Present (Full_View (gnat_entity)))
9135 {
9136 Entity_Id full_view = Full_View (gnat_entity);
9137
9138 if (Is_Private_Type (full_view)
9139 && Present (Underlying_Full_View (full_view)))
9140 full_view = Underlying_Full_View (full_view);
9141
9142 gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, true);
9143
9144 /* Propagate back-annotations from full view to partial view. */
9145 if (Unknown_Alignment (gnat_entity))
9146 Set_Alignment (gnat_entity, Alignment (full_view));
9147
9148 if (Unknown_Esize (gnat_entity))
9149 Set_Esize (gnat_entity, Esize (full_view));
9150
9151 if (Unknown_RM_Size (gnat_entity))
9152 Set_RM_Size (gnat_entity, RM_Size (full_view));
9153
9154 /* The above call may have defined this entity (the simplest example
9155 of this is when we have a private enumeral type since the bounds
9156 will have the public view). */
9157 if (!present_gnu_tree (gnat_entity))
9158 save_gnu_tree (gnat_entity, gnu_new, false);
9159 }
9160 else
9161 {
9162 tree gnu_init
9163 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
9164 && present_gnu_tree (Declaration_Node (gnat_entity)))
9165 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
9166
9167 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, true);
9168 }
9169
9170 if (Is_Type (gnat_entity)
9171 && Present (Class_Wide_Type (gnat_entity))
9172 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
9173 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
9174
9175 /* If we have an old type and we've made pointers to this type, update those
9176 pointers. If this is a Taft amendment type in the main unit, we need to
9177 mark the type as used since other units referencing it don't see the full
9178 declaration and, therefore, cannot mark it as used themselves. */
9179 if (gnu_old)
9180 {
9181 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
9182 TREE_TYPE (gnu_new));
9183 if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old)))
9184 update_profiles_with (TREE_TYPE (gnu_old));
9185 if (DECL_TAFT_TYPE_P (gnu_old))
9186 used_types_insert (TREE_TYPE (gnu_new));
9187 }
9188 }
9189
9190 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
9191 We make two passes, one to elaborate anything other than bodies (but
9192 we declare a function if there was no spec). The second pass
9193 elaborates the bodies.
9194
9195 GNAT_END_LIST gives the element in the list past the end. Normally,
9196 this is Empty, but can be First_Real_Statement for a
9197 Handled_Sequence_Of_Statements.
9198
9199 We make a complete pass through both lists if PASS1P is true, then make
9200 the second pass over both lists if PASS2P is true. The lists usually
9201 correspond to the public and private parts of a package. */
9202
9203 static void
process_decls(List_Id gnat_decls,List_Id gnat_decls2,Node_Id gnat_end_list,bool pass1p,bool pass2p)9204 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
9205 Node_Id gnat_end_list, bool pass1p, bool pass2p)
9206 {
9207 List_Id gnat_decl_array[2];
9208 Node_Id gnat_decl;
9209 int i;
9210
9211 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
9212
9213 if (pass1p)
9214 for (i = 0; i <= 1; i++)
9215 if (Present (gnat_decl_array[i]))
9216 for (gnat_decl = First (gnat_decl_array[i]);
9217 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
9218 {
9219 /* For package specs, we recurse inside the declarations,
9220 thus taking the two pass approach inside the boundary. */
9221 if (Nkind (gnat_decl) == N_Package_Declaration
9222 && (Nkind (Specification (gnat_decl)
9223 == N_Package_Specification)))
9224 process_decls (Visible_Declarations (Specification (gnat_decl)),
9225 Private_Declarations (Specification (gnat_decl)),
9226 Empty, true, false);
9227
9228 /* Similarly for any declarations in the actions of a
9229 freeze node. */
9230 else if (Nkind (gnat_decl) == N_Freeze_Entity)
9231 {
9232 process_freeze_entity (gnat_decl);
9233 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
9234 }
9235
9236 /* Package bodies with freeze nodes get their elaboration deferred
9237 until the freeze node, but the code must be placed in the right
9238 place, so record the code position now. */
9239 else if (Nkind (gnat_decl) == N_Package_Body
9240 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
9241 record_code_position (gnat_decl);
9242
9243 else if (Nkind (gnat_decl) == N_Package_Body_Stub
9244 && Present (Library_Unit (gnat_decl))
9245 && Present (Freeze_Node
9246 (Corresponding_Spec
9247 (Proper_Body (Unit
9248 (Library_Unit (gnat_decl)))))))
9249 record_code_position
9250 (Proper_Body (Unit (Library_Unit (gnat_decl))));
9251
9252 /* We defer most subprogram bodies to the second pass. */
9253 else if (Nkind (gnat_decl) == N_Subprogram_Body)
9254 {
9255 if (Acts_As_Spec (gnat_decl))
9256 {
9257 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
9258
9259 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
9260 && Ekind (gnat_subprog_id) != E_Generic_Function)
9261 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, true);
9262 }
9263 }
9264
9265 /* For bodies and stubs that act as their own specs, the entity
9266 itself must be elaborated in the first pass, because it may
9267 be used in other declarations. */
9268 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
9269 {
9270 Node_Id gnat_subprog_id
9271 = Defining_Entity (Specification (gnat_decl));
9272
9273 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
9274 && Ekind (gnat_subprog_id) != E_Generic_Procedure
9275 && Ekind (gnat_subprog_id) != E_Generic_Function)
9276 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, true);
9277 }
9278
9279 /* Concurrent stubs stand for the corresponding subprogram bodies,
9280 which are deferred like other bodies. */
9281 else if (Nkind (gnat_decl) == N_Task_Body_Stub
9282 || Nkind (gnat_decl) == N_Protected_Body_Stub)
9283 ;
9284
9285 /* Renamed subprograms may not be elaborated yet at this point
9286 since renamings do not trigger freezing. Wait for the second
9287 pass to take care of them. */
9288 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
9289 ;
9290
9291 else
9292 add_stmt (gnat_to_gnu (gnat_decl));
9293 }
9294
9295 /* Here we elaborate everything we deferred above except for package bodies,
9296 which are elaborated at their freeze nodes. Note that we must also
9297 go inside things (package specs and freeze nodes) the first pass did. */
9298 if (pass2p)
9299 for (i = 0; i <= 1; i++)
9300 if (Present (gnat_decl_array[i]))
9301 for (gnat_decl = First (gnat_decl_array[i]);
9302 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
9303 {
9304 if (Nkind (gnat_decl) == N_Subprogram_Body
9305 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
9306 || Nkind (gnat_decl) == N_Task_Body_Stub
9307 || Nkind (gnat_decl) == N_Protected_Body_Stub)
9308 add_stmt (gnat_to_gnu (gnat_decl));
9309
9310 else if (Nkind (gnat_decl) == N_Package_Declaration
9311 && (Nkind (Specification (gnat_decl)
9312 == N_Package_Specification)))
9313 process_decls (Visible_Declarations (Specification (gnat_decl)),
9314 Private_Declarations (Specification (gnat_decl)),
9315 Empty, false, true);
9316
9317 else if (Nkind (gnat_decl) == N_Freeze_Entity)
9318 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
9319
9320 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
9321 add_stmt (gnat_to_gnu (gnat_decl));
9322 }
9323 }
9324
9325 /* Make a unary operation of kind CODE using build_unary_op, but guard
9326 the operation by an overflow check. CODE can be one of NEGATE_EXPR
9327 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
9328 the operation is to be performed in that type. GNAT_NODE is the gnat
9329 node conveying the source location for which the error should be
9330 signaled. */
9331
9332 static tree
build_unary_op_trapv(enum tree_code code,tree gnu_type,tree operand,Node_Id gnat_node)9333 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
9334 Node_Id gnat_node)
9335 {
9336 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
9337
9338 operand = gnat_protect_expr (operand);
9339
9340 return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
9341 operand, TYPE_MIN_VALUE (gnu_type)),
9342 build_unary_op (code, gnu_type, operand),
9343 CE_Overflow_Check_Failed, gnat_node);
9344 }
9345
9346 /* Make a binary operation of kind CODE using build_binary_op, but guard
9347 the operation by an overflow check. CODE can be one of PLUS_EXPR,
9348 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
9349 Usually the operation is to be performed in that type. GNAT_NODE is
9350 the GNAT node conveying the source location for which the error should
9351 be signaled. */
9352
9353 static tree
build_binary_op_trapv(enum tree_code code,tree gnu_type,tree left,tree right,Node_Id gnat_node)9354 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
9355 tree right, Node_Id gnat_node)
9356 {
9357 const unsigned int precision = TYPE_PRECISION (gnu_type);
9358 tree lhs = gnat_protect_expr (left);
9359 tree rhs = gnat_protect_expr (right);
9360 tree type_max = TYPE_MAX_VALUE (gnu_type);
9361 tree type_min = TYPE_MIN_VALUE (gnu_type);
9362 tree gnu_expr, check;
9363 int sgn;
9364
9365 /* Assert that the precision is a power of 2. */
9366 gcc_assert ((precision & (precision - 1)) == 0);
9367
9368 /* Prefer a constant on the RHS to simplify checks. */
9369 if (TREE_CODE (rhs) != INTEGER_CST
9370 && TREE_CODE (lhs) == INTEGER_CST
9371 && (code == PLUS_EXPR || code == MULT_EXPR))
9372 {
9373 tree tmp = lhs;
9374 lhs = rhs;
9375 rhs = tmp;
9376 }
9377
9378 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
9379
9380 /* If we can fold the expression to a constant, just return it.
9381 The caller will deal with overflow, no need to generate a check. */
9382 if (TREE_CODE (gnu_expr) == INTEGER_CST)
9383 return gnu_expr;
9384
9385 /* If no operand is a constant, we use the generic implementation. */
9386 if (TREE_CODE (lhs) != INTEGER_CST && TREE_CODE (rhs) != INTEGER_CST)
9387 {
9388 /* First convert the operands to the result type like build_binary_op.
9389 This is where the bias is made explicit for biased types. */
9390 lhs = convert (gnu_type, lhs);
9391 rhs = convert (gnu_type, rhs);
9392
9393 /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
9394 if (code == MULT_EXPR && precision == 64 && BITS_PER_WORD < 64)
9395 {
9396 tree int64 = gnat_type_for_size (64, 0);
9397 return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
9398 convert (int64, lhs),
9399 convert (int64, rhs)));
9400 }
9401
9402 /* Likewise for a 128-bit mult and a 64-bit target. */
9403 else if (code == MULT_EXPR && precision == 128 && BITS_PER_WORD < 128)
9404 {
9405 tree int128 = gnat_type_for_size (128, 0);
9406 return convert (gnu_type, build_call_n_expr (mulv128_decl, 2,
9407 convert (int128, lhs),
9408 convert (int128, rhs)));
9409 }
9410
9411 enum internal_fn icode;
9412
9413 switch (code)
9414 {
9415 case PLUS_EXPR:
9416 icode = IFN_ADD_OVERFLOW;
9417 break;
9418 case MINUS_EXPR:
9419 icode = IFN_SUB_OVERFLOW;
9420 break;
9421 case MULT_EXPR:
9422 icode = IFN_MUL_OVERFLOW;
9423 break;
9424 default:
9425 gcc_unreachable ();
9426 }
9427
9428 tree gnu_ctype = build_complex_type (gnu_type);
9429 tree call
9430 = build_call_expr_internal_loc (UNKNOWN_LOCATION, icode, gnu_ctype, 2,
9431 lhs, rhs);
9432 tree tgt = save_expr (call);
9433 gnu_expr = build1 (REALPART_EXPR, gnu_type, tgt);
9434 check = fold_build2 (NE_EXPR, boolean_type_node,
9435 build1 (IMAGPART_EXPR, gnu_type, tgt),
9436 build_int_cst (gnu_type, 0));
9437 return
9438 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
9439 }
9440
9441 /* If one operand is a constant, we expose the overflow condition to enable
9442 a subsequent simplication or even elimination. */
9443 switch (code)
9444 {
9445 case PLUS_EXPR:
9446 sgn = tree_int_cst_sgn (rhs);
9447 if (sgn > 0)
9448 /* When rhs > 0, overflow when lhs > type_max - rhs. */
9449 check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
9450 build_binary_op (MINUS_EXPR, gnu_type,
9451 type_max, rhs));
9452 else if (sgn < 0)
9453 /* When rhs < 0, overflow when lhs < type_min - rhs. */
9454 check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
9455 build_binary_op (MINUS_EXPR, gnu_type,
9456 type_min, rhs));
9457 else
9458 return gnu_expr;
9459 break;
9460
9461 case MINUS_EXPR:
9462 if (TREE_CODE (lhs) == INTEGER_CST)
9463 {
9464 sgn = tree_int_cst_sgn (lhs);
9465 if (sgn > 0)
9466 /* When lhs > 0, overflow when rhs < lhs - type_max. */
9467 check = build_binary_op (LT_EXPR, boolean_type_node, rhs,
9468 build_binary_op (MINUS_EXPR, gnu_type,
9469 lhs, type_max));
9470 else if (sgn < 0)
9471 /* When lhs < 0, overflow when rhs > lhs - type_min. */
9472 check = build_binary_op (GT_EXPR, boolean_type_node, rhs,
9473 build_binary_op (MINUS_EXPR, gnu_type,
9474 lhs, type_min));
9475 else
9476 return gnu_expr;
9477 }
9478 else
9479 {
9480 sgn = tree_int_cst_sgn (rhs);
9481 if (sgn > 0)
9482 /* When rhs > 0, overflow when lhs < type_min + rhs. */
9483 check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
9484 build_binary_op (PLUS_EXPR, gnu_type,
9485 type_min, rhs));
9486 else if (sgn < 0)
9487 /* When rhs < 0, overflow when lhs > type_max + rhs. */
9488 check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
9489 build_binary_op (PLUS_EXPR, gnu_type,
9490 type_max, rhs));
9491 else
9492 return gnu_expr;
9493 }
9494 break;
9495
9496 case MULT_EXPR:
9497 sgn = tree_int_cst_sgn (rhs);
9498 if (sgn > 0)
9499 {
9500 if (integer_onep (rhs))
9501 return gnu_expr;
9502
9503 tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
9504 tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
9505
9506 /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
9507 check
9508 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9509 build_binary_op (LT_EXPR, boolean_type_node,
9510 lhs, lb),
9511 build_binary_op (GT_EXPR, boolean_type_node,
9512 lhs, ub));
9513 }
9514 else if (sgn < 0)
9515 {
9516 tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
9517 tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
9518
9519 if (integer_minus_onep (rhs))
9520 /* When rhs == -1, overflow if lhs == type_min. */
9521 check
9522 = build_binary_op (EQ_EXPR, boolean_type_node, lhs, type_min);
9523 else
9524 /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
9525 check
9526 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9527 build_binary_op (LT_EXPR, boolean_type_node,
9528 lhs, lb),
9529 build_binary_op (GT_EXPR, boolean_type_node,
9530 lhs, ub));
9531 }
9532 else
9533 return gnu_expr;
9534 break;
9535
9536 default:
9537 gcc_unreachable ();
9538 }
9539
9540 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
9541 }
9542
9543 /* GNU_COND contains the condition corresponding to an index, overflow or
9544 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9545 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9546 REASON is the code that says why the exception is raised. GNAT_NODE is
9547 the node conveying the source location for which the error should be
9548 signaled.
9549
9550 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9551 overwriting the setting inherited from the call statement, on the ground
9552 that the expression need not be evaluated just for the check. However
9553 that's incorrect because, in the GCC type system, its value is presumed
9554 to be valid so its comparison against the type bounds always yields true
9555 and, therefore, could be done without evaluating it; given that it can
9556 be a computation that overflows the bounds, the language may require the
9557 check to fail and thus the expression to be evaluated in this case. */
9558
9559 static tree
emit_check(tree gnu_cond,tree gnu_expr,int reason,Node_Id gnat_node)9560 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
9561 {
9562 tree gnu_call
9563 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
9564 return
9565 fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
9566 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
9567 SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr))
9568 ? build_real (TREE_TYPE (gnu_expr), dconst0)
9569 : build_int_cst (TREE_TYPE (gnu_expr), 0)),
9570 gnu_expr);
9571 }
9572
9573 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
9574 checks if OVERFLOW_P is true. If TRUNCATE_P is true, do a fp-to-integer
9575 conversion with truncation, otherwise round. GNAT_NODE is the GNAT node
9576 conveying the source location for which the error should be signaled. */
9577
9578 static tree
convert_with_check(Entity_Id gnat_type,tree gnu_expr,bool overflow_p,bool truncate_p,Node_Id gnat_node)9579 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
9580 bool truncate_p, Node_Id gnat_node)
9581 {
9582 tree gnu_type = get_unpadded_type (gnat_type);
9583 tree gnu_base_type = get_base_type (gnu_type);
9584 tree gnu_in_type = TREE_TYPE (gnu_expr);
9585 tree gnu_in_base_type = get_base_type (gnu_in_type);
9586 tree gnu_result = gnu_expr;
9587
9588 /* If we are not doing any checks, the output is an integral type and the
9589 input is not a floating-point type, just do the conversion. This is
9590 required for packed array types and is simpler in all cases anyway. */
9591 if (!overflow_p
9592 && INTEGRAL_TYPE_P (gnu_base_type)
9593 && !FLOAT_TYPE_P (gnu_in_base_type))
9594 return convert (gnu_type, gnu_expr);
9595
9596 /* If the mode of the input base type is larger, then converting to it below
9597 may pessimize the final conversion step, for example generate a libcall
9598 instead of a simple instruction, so use a narrower type in this case. */
9599 if (TYPE_MODE (gnu_in_base_type) != TYPE_MODE (gnu_in_type)
9600 && !(TREE_CODE (gnu_in_type) == INTEGER_TYPE
9601 && TYPE_BIASED_REPRESENTATION_P (gnu_in_type)))
9602 gnu_in_base_type = gnat_type_for_mode (TYPE_MODE (gnu_in_type),
9603 TYPE_UNSIGNED (gnu_in_type));
9604
9605 /* First convert the expression to the base type. This will never generate
9606 code, but makes the tests below simpler. But don't do this if converting
9607 from an integer type to an unconstrained array type since then we need to
9608 get the bounds from the original (unpacked) type. */
9609 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
9610 gnu_result = convert (gnu_in_base_type, gnu_result);
9611
9612 /* If overflow checks are requested, we need to be sure the result will fit
9613 in the output base type. But don't do this if the input is integer and
9614 the output floating-point. */
9615 if (overflow_p
9616 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_base_type)))
9617 {
9618 /* Ensure GNU_EXPR only gets evaluated once. */
9619 tree gnu_input = gnat_protect_expr (gnu_result);
9620 tree gnu_cond = boolean_false_node;
9621 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_base_type);
9622 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_base_type);
9623 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
9624 tree gnu_out_ub
9625 = (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9626 && TYPE_MODULAR_P (gnu_base_type))
9627 ? fold_build2 (MINUS_EXPR, gnu_base_type,
9628 TYPE_MODULUS (gnu_base_type),
9629 build_int_cst (gnu_base_type, 1))
9630 : TYPE_MAX_VALUE (gnu_base_type);
9631
9632 /* Convert the lower bounds to signed types, so we're sure we're
9633 comparing them properly. Likewise, convert the upper bounds
9634 to unsigned types. */
9635 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9636 && TYPE_UNSIGNED (gnu_in_base_type))
9637 gnu_in_lb
9638 = convert (gnat_signed_type_for (gnu_in_base_type), gnu_in_lb);
9639
9640 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9641 && !TYPE_UNSIGNED (gnu_in_base_type))
9642 gnu_in_ub
9643 = convert (gnat_unsigned_type_for (gnu_in_base_type), gnu_in_ub);
9644
9645 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
9646 gnu_out_lb
9647 = convert (gnat_signed_type_for (gnu_base_type), gnu_out_lb);
9648
9649 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
9650 gnu_out_ub
9651 = convert (gnat_unsigned_type_for (gnu_base_type), gnu_out_ub);
9652
9653 /* Check each bound separately and only if the result bound
9654 is tighter than the bound on the input type. Note that all the
9655 types are base types, so the bounds must be constant. Also,
9656 the comparison is done in the base type of the input, which
9657 always has the proper signedness. First check for input
9658 integer (which means output integer), output float (which means
9659 both float), or mixed, in which case we always compare.
9660 Note that we have to do the comparison which would *fail* in the
9661 case of an error since if it's an FP comparison and one of the
9662 values is a NaN or Inf, the comparison will fail. */
9663 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9664 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
9665 : (FLOAT_TYPE_P (gnu_base_type)
9666 ? real_less (&TREE_REAL_CST (gnu_in_lb),
9667 &TREE_REAL_CST (gnu_out_lb))
9668 : 1))
9669 gnu_cond
9670 = invert_truthvalue
9671 (build_binary_op (GE_EXPR, boolean_type_node,
9672 gnu_input, convert (gnu_in_base_type,
9673 gnu_out_lb)));
9674
9675 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9676 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
9677 : (FLOAT_TYPE_P (gnu_base_type)
9678 ? real_less (&TREE_REAL_CST (gnu_out_ub),
9679 &TREE_REAL_CST (gnu_in_ub))
9680 : 1))
9681 gnu_cond
9682 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
9683 invert_truthvalue
9684 (build_binary_op (LE_EXPR, boolean_type_node,
9685 gnu_input,
9686 convert (gnu_in_base_type,
9687 gnu_out_ub))));
9688
9689 if (!integer_zerop (gnu_cond))
9690 gnu_result = emit_check (gnu_cond, gnu_input,
9691 CE_Overflow_Check_Failed, gnat_node);
9692 }
9693
9694 /* Now convert to the result base type. If this is a non-truncating
9695 float-to-integer conversion, round. */
9696 if (INTEGRAL_TYPE_P (gnu_base_type)
9697 && FLOAT_TYPE_P (gnu_in_base_type)
9698 && !truncate_p)
9699 {
9700 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
9701 tree gnu_conv, gnu_zero, gnu_comp, calc_type;
9702 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
9703 const struct real_format *fmt;
9704
9705 /* The following calculations depend on proper rounding to even
9706 of each arithmetic operation. In order to prevent excess
9707 precision from spoiling this property, use the widest hardware
9708 floating-point type if FP_ARITH_MAY_WIDEN is true. */
9709 calc_type
9710 = fp_arith_may_widen ? longest_float_type_node : gnu_in_base_type;
9711
9712 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
9713 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
9714 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
9715 real_arithmetic (&pred_half, MINUS_EXPR, &dconsthalf,
9716 &half_minus_pred_half);
9717 gnu_pred_half = build_real (calc_type, pred_half);
9718
9719 /* If the input is strictly negative, subtract this value
9720 and otherwise add it from the input. For 0.5, the result
9721 is exactly between 1.0 and the machine number preceding 1.0
9722 (for calc_type). Since the last bit of 1.0 is even, this 0.5
9723 will round to 1.0, while all other number with an absolute
9724 value less than 0.5 round to 0.0. For larger numbers exactly
9725 halfway between integers, rounding will always be correct as
9726 the true mathematical result will be closer to the higher
9727 integer compared to the lower one. So, this constant works
9728 for all floating-point numbers.
9729
9730 The reason to use the same constant with subtract/add instead
9731 of a positive and negative constant is to allow the comparison
9732 to be scheduled in parallel with retrieval of the constant and
9733 conversion of the input to the calc_type (if necessary). */
9734
9735 gnu_zero = build_real (gnu_in_base_type, dconst0);
9736 gnu_result = gnat_protect_expr (gnu_result);
9737 gnu_conv = convert (calc_type, gnu_result);
9738 gnu_comp
9739 = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
9740 gnu_add_pred_half
9741 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9742 gnu_subtract_pred_half
9743 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9744 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
9745 gnu_add_pred_half, gnu_subtract_pred_half);
9746 }
9747
9748 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9749 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
9750 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
9751 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
9752 else
9753 gnu_result = convert (gnu_base_type, gnu_result);
9754
9755 return convert (gnu_type, gnu_result);
9756 }
9757
9758 /* Return true if GNU_EXPR can be directly addressed. This is the case
9759 unless it is an expression involving computation or if it involves a
9760 reference to a bitfield or to an object not sufficiently aligned for
9761 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
9762 be directly addressed as an object of this type.
9763
9764 *** Notes on addressability issues in the Ada compiler ***
9765
9766 This predicate is necessary in order to bridge the gap between Gigi
9767 and the middle-end about addressability of GENERIC trees. A tree
9768 is said to be addressable if it can be directly addressed, i.e. if
9769 its address can be taken, is a multiple of the type's alignment on
9770 strict-alignment architectures and returns the first storage unit
9771 assigned to the object represented by the tree.
9772
9773 In the C family of languages, everything is in practice addressable
9774 at the language level, except for bit-fields. This means that these
9775 compilers will take the address of any tree that doesn't represent
9776 a bit-field reference and expect the result to be the first storage
9777 unit assigned to the object. Even in cases where this will result
9778 in unaligned accesses at run time, nothing is supposed to be done
9779 and the program is considered as erroneous instead (see PR c/18287).
9780
9781 The implicit assumptions made in the middle-end are in keeping with
9782 the C viewpoint described above:
9783 - the address of a bit-field reference is supposed to be never
9784 taken; the compiler (generally) will stop on such a construct,
9785 - any other tree is addressable if it is formally addressable,
9786 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
9787
9788 In Ada, the viewpoint is the opposite one: nothing is addressable
9789 at the language level unless explicitly declared so. This means
9790 that the compiler will both make sure that the trees representing
9791 references to addressable ("aliased" in Ada parlance) objects are
9792 addressable and make no real attempts at ensuring that the trees
9793 representing references to non-addressable objects are addressable.
9794
9795 In the first case, Ada is effectively equivalent to C and handing
9796 down the direct result of applying ADDR_EXPR to these trees to the
9797 middle-end works flawlessly. In the second case, Ada cannot afford
9798 to consider the program as erroneous if the address of trees that
9799 are not addressable is requested for technical reasons, unlike C;
9800 as a consequence, the Ada compiler must arrange for either making
9801 sure that this address is not requested in the middle-end or for
9802 compensating by inserting temporaries if it is requested in Gigi.
9803
9804 The first goal can be achieved because the middle-end should not
9805 request the address of non-addressable trees on its own; the only
9806 exception is for the invocation of low-level block operations like
9807 memcpy, for which the addressability requirements are lower since
9808 the type's alignment can be disregarded. In practice, this means
9809 that Gigi must make sure that such operations cannot be applied to
9810 non-BLKmode bit-fields.
9811
9812 The second goal is achieved by means of the addressable_p predicate,
9813 which computes whether a temporary must be inserted by Gigi when the
9814 address of a tree is requested; if so, the address of the temporary
9815 will be used in lieu of that of the original tree and some glue code
9816 generated to connect everything together. */
9817
9818 static bool
addressable_p(tree gnu_expr,tree gnu_type)9819 addressable_p (tree gnu_expr, tree gnu_type)
9820 {
9821 /* For an integral type, the size of the actual type of the object may not
9822 be greater than that of the expected type, otherwise an indirect access
9823 in the latter type wouldn't correctly set all the bits of the object. */
9824 if (gnu_type
9825 && INTEGRAL_TYPE_P (gnu_type)
9826 && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
9827 return false;
9828
9829 /* The size of the actual type of the object may not be smaller than that
9830 of the expected type, otherwise an indirect access in the latter type
9831 would be larger than the object. But only record types need to be
9832 considered in practice for this case. */
9833 if (gnu_type
9834 && TREE_CODE (gnu_type) == RECORD_TYPE
9835 && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
9836 return false;
9837
9838 switch (TREE_CODE (gnu_expr))
9839 {
9840 case VAR_DECL:
9841 case PARM_DECL:
9842 case FUNCTION_DECL:
9843 case RESULT_DECL:
9844 /* All DECLs are addressable: if they are in a register, we can force
9845 them to memory. */
9846 return true;
9847
9848 case UNCONSTRAINED_ARRAY_REF:
9849 case INDIRECT_REF:
9850 /* Taking the address of a dereference yields the original pointer. */
9851 return true;
9852
9853 case STRING_CST:
9854 case INTEGER_CST:
9855 case REAL_CST:
9856 /* Taking the address yields a pointer to the constant pool. */
9857 return true;
9858
9859 case CONSTRUCTOR:
9860 /* Taking the address of a static constructor yields a pointer to the
9861 tree constant pool. */
9862 return TREE_STATIC (gnu_expr) ? true : false;
9863
9864 case NULL_EXPR:
9865 case ADDR_EXPR:
9866 case SAVE_EXPR:
9867 case CALL_EXPR:
9868 case PLUS_EXPR:
9869 case MINUS_EXPR:
9870 case BIT_IOR_EXPR:
9871 case BIT_XOR_EXPR:
9872 case BIT_AND_EXPR:
9873 case BIT_NOT_EXPR:
9874 /* All rvalues are deemed addressable since taking their address will
9875 force a temporary to be created by the middle-end. */
9876 return true;
9877
9878 case COMPOUND_EXPR:
9879 /* The address of a compound expression is that of its 2nd operand. */
9880 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
9881
9882 case COND_EXPR:
9883 /* We accept &COND_EXPR as soon as both operands are addressable and
9884 expect the outcome to be the address of the selected operand. */
9885 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
9886 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
9887
9888 case COMPONENT_REF:
9889 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
9890 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
9891 the field is sufficiently aligned, in case it is subject
9892 to a pragma Component_Alignment. But we don't need to
9893 check the alignment of the containing record, as it is
9894 guaranteed to be not smaller than that of its most
9895 aligned field that is not a bit-field. */
9896 && (!STRICT_ALIGNMENT
9897 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
9898 >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
9899 /* The field of a padding record is always addressable. */
9900 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
9901 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9902
9903 case ARRAY_REF: case ARRAY_RANGE_REF:
9904 case REALPART_EXPR: case IMAGPART_EXPR:
9905 case NOP_EXPR:
9906 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
9907
9908 case CONVERT_EXPR:
9909 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
9910 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9911
9912 case VIEW_CONVERT_EXPR:
9913 {
9914 /* This is addressable if we can avoid a copy. */
9915 tree type = TREE_TYPE (gnu_expr);
9916 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
9917 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
9918 && (!STRICT_ALIGNMENT
9919 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
9920 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
9921 || ((TYPE_MODE (type) == BLKmode
9922 || TYPE_MODE (inner_type) == BLKmode)
9923 && (!STRICT_ALIGNMENT
9924 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
9925 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
9926 || TYPE_ALIGN_OK (type)
9927 || TYPE_ALIGN_OK (inner_type))))
9928 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9929 }
9930
9931 default:
9932 return false;
9933 }
9934 }
9935
9936 /* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
9937 If a Freeze node exists for the entity, delay the bulk of the processing.
9938 Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
9939
9940 void
process_type(Entity_Id gnat_entity)9941 process_type (Entity_Id gnat_entity)
9942 {
9943 tree gnu_old
9944 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
9945
9946 /* If we are to delay elaboration of this type, just do any elaboration
9947 needed for expressions within the declaration and make a dummy node
9948 for it and its Full_View (if any), in case something points to it.
9949 Do not do this if it has already been done (the only way that can
9950 happen is if the private completion is also delayed). */
9951 if (Present (Freeze_Node (gnat_entity)))
9952 {
9953 elaborate_entity (gnat_entity);
9954
9955 if (!gnu_old)
9956 {
9957 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
9958 save_gnu_tree (gnat_entity, gnu_decl, false);
9959 if (Is_Incomplete_Or_Private_Type (gnat_entity)
9960 && Present (Full_View (gnat_entity)))
9961 {
9962 if (Has_Completion_In_Body (gnat_entity))
9963 DECL_TAFT_TYPE_P (gnu_decl) = 1;
9964 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
9965 }
9966 }
9967
9968 return;
9969 }
9970
9971 /* If we saved away a dummy type for this node, it means that this made the
9972 type that corresponds to the full type of an incomplete type. Clear that
9973 type for now and then update the type in the pointers below. But, if the
9974 saved type is not dummy, it very likely means that we have a use before
9975 declaration for the type in the tree, what we really cannot handle. */
9976 if (gnu_old)
9977 {
9978 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
9979 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
9980
9981 save_gnu_tree (gnat_entity, NULL_TREE, false);
9982 }
9983
9984 /* Now fully elaborate the type. */
9985 tree gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, true);
9986 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
9987
9988 /* If we have an old type and we've made pointers to this type, update those
9989 pointers. If this is a Taft amendment type in the main unit, we need to
9990 mark the type as used since other units referencing it don't see the full
9991 declaration and, therefore, cannot mark it as used themselves. */
9992 if (gnu_old)
9993 {
9994 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
9995 TREE_TYPE (gnu_new));
9996 if (DECL_TAFT_TYPE_P (gnu_old))
9997 used_types_insert (TREE_TYPE (gnu_new));
9998 }
9999
10000 /* If this is a record type corresponding to a task or protected type
10001 that is a completion of an incomplete type, perform a similar update
10002 on the type. ??? Including protected types here is a guess. */
10003 if (Is_Record_Type (gnat_entity)
10004 && Is_Concurrent_Record_Type (gnat_entity)
10005 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
10006 {
10007 tree gnu_task_old
10008 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
10009
10010 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
10011 NULL_TREE, false);
10012 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
10013 gnu_new, false);
10014
10015 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
10016 TREE_TYPE (gnu_new));
10017 }
10018 }
10019
10020 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
10021 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
10022 associations that are from RECORD_TYPE. If we see an internal record, make
10023 a recursive call to fill it in as well. */
10024
10025 static tree
extract_values(tree values,tree record_type)10026 extract_values (tree values, tree record_type)
10027 {
10028 vec<constructor_elt, va_gc> *v = NULL;
10029 tree field;
10030
10031 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
10032 {
10033 tree tem, value = NULL_TREE;
10034
10035 /* _Parent is an internal field, but may have values in the aggregate,
10036 so check for values first. */
10037 if ((tem = purpose_member (field, values)))
10038 {
10039 value = TREE_VALUE (tem);
10040 TREE_ADDRESSABLE (tem) = 1;
10041 }
10042
10043 else if (DECL_INTERNAL_P (field))
10044 {
10045 value = extract_values (values, TREE_TYPE (field));
10046 if (TREE_CODE (value) == CONSTRUCTOR
10047 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value)))
10048 value = NULL_TREE;
10049 }
10050 else
10051 /* If we have a record subtype, the names will match, but not the
10052 actual FIELD_DECLs. */
10053 for (tem = values; tem; tem = TREE_CHAIN (tem))
10054 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
10055 {
10056 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
10057 TREE_ADDRESSABLE (tem) = 1;
10058 }
10059
10060 if (!value)
10061 continue;
10062
10063 CONSTRUCTOR_APPEND_ELT (v, field, value);
10064 }
10065
10066 return gnat_build_constructor (record_type, v);
10067 }
10068
10069 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
10070 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
10071 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
10072
10073 static tree
assoc_to_constructor(Entity_Id gnat_entity,Node_Id gnat_assoc,tree gnu_type)10074 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
10075 {
10076 tree gnu_list = NULL_TREE, gnu_result;
10077
10078 /* We test for GNU_FIELD being empty in the case where a variant
10079 was the last thing since we don't take things off GNAT_ASSOC in
10080 that case. We check GNAT_ASSOC in case we have a variant, but it
10081 has no fields. */
10082
10083 for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
10084 {
10085 const Node_Id gnat_field = First (Choices (gnat_assoc));
10086 const Node_Id gnat_expr = Expression (gnat_assoc);
10087 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
10088 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
10089
10090 /* The expander is supposed to put a single component selector name
10091 in every record component association. */
10092 gcc_assert (No (Next (gnat_field)));
10093
10094 /* Ignore discriminants that have Corresponding_Discriminants in tagged
10095 types since we'll be setting those fields in the parent subtype. */
10096 if (Ekind (Entity (gnat_field)) == E_Discriminant
10097 && Present (Corresponding_Discriminant (Entity (gnat_field)))
10098 && Is_Tagged_Type (Scope (Entity (gnat_field))))
10099 continue;
10100
10101 /* Also ignore discriminants of Unchecked_Unions. */
10102 if (Ekind (Entity (gnat_field)) == E_Discriminant
10103 && Is_Unchecked_Union (gnat_entity))
10104 continue;
10105
10106 gigi_checking_assert (!Do_Range_Check (gnat_expr));
10107
10108 /* Convert to the type of the field. */
10109 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
10110
10111 /* Add the field and expression to the list. */
10112 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
10113 }
10114
10115 gnu_result = extract_values (gnu_list, gnu_type);
10116
10117 if (flag_checking)
10118 {
10119 /* Verify that every entry in GNU_LIST was used. */
10120 for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
10121 gcc_assert (TREE_ADDRESSABLE (gnu_list));
10122 }
10123
10124 return gnu_result;
10125 }
10126
10127 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
10128 the first element of an array aggregate. It may itself be an aggregate.
10129 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate. */
10130
10131 static tree
pos_to_constructor(Node_Id gnat_expr,tree gnu_array_type)10132 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type)
10133 {
10134 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
10135 vec<constructor_elt, va_gc> *gnu_expr_vec = NULL;
10136
10137 for (; Present (gnat_expr); gnat_expr = Next (gnat_expr))
10138 {
10139 tree gnu_expr;
10140
10141 /* If the expression is itself an array aggregate then first build the
10142 innermost constructor if it is part of our array (multi-dimensional
10143 case). */
10144 if (Nkind (gnat_expr) == N_Aggregate
10145 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
10146 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
10147 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
10148 TREE_TYPE (gnu_array_type));
10149 else
10150 {
10151 /* If the expression is a conversion to an unconstrained array type,
10152 skip it to avoid spilling to memory. */
10153 if (Nkind (gnat_expr) == N_Type_Conversion
10154 && Is_Array_Type (Etype (gnat_expr))
10155 && !Is_Constrained (Etype (gnat_expr)))
10156 gnu_expr = gnat_to_gnu (Expression (gnat_expr));
10157 else
10158 gnu_expr = gnat_to_gnu (gnat_expr);
10159
10160 gigi_checking_assert (!Do_Range_Check (gnat_expr));
10161 }
10162
10163 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
10164 convert (TREE_TYPE (gnu_array_type), gnu_expr));
10165
10166 gnu_index = int_const_binop (PLUS_EXPR, gnu_index,
10167 convert (TREE_TYPE (gnu_index),
10168 integer_one_node));
10169 }
10170
10171 return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
10172 }
10173
10174 /* Process a N_Validate_Unchecked_Conversion node. */
10175
10176 static void
validate_unchecked_conversion(Node_Id gnat_node)10177 validate_unchecked_conversion (Node_Id gnat_node)
10178 {
10179 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
10180 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
10181
10182 /* If the target is a pointer type, see if we are either converting from a
10183 non-pointer or from a pointer to a type with a different alias set and
10184 warn if so, unless the pointer has been marked to alias everything. */
10185 if (POINTER_TYPE_P (gnu_target_type)
10186 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
10187 {
10188 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
10189 ? TREE_TYPE (gnu_source_type)
10190 : NULL_TREE;
10191 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
10192 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
10193
10194 if (target_alias_set != 0
10195 && (!POINTER_TYPE_P (gnu_source_type)
10196 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
10197 target_alias_set)))
10198 {
10199 post_error_ne ("?possible aliasing problem for type&",
10200 gnat_node, Target_Type (gnat_node));
10201 post_error ("\\?use -fno-strict-aliasing switch for references",
10202 gnat_node);
10203 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
10204 gnat_node, Target_Type (gnat_node));
10205 }
10206 }
10207
10208 /* Likewise if the target is a fat pointer type, but we have no mechanism to
10209 mitigate the problem in this case, so we unconditionally warn. */
10210 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
10211 {
10212 tree gnu_source_desig_type
10213 = TYPE_IS_FAT_POINTER_P (gnu_source_type)
10214 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
10215 : NULL_TREE;
10216 tree gnu_target_desig_type
10217 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
10218 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
10219
10220 if (target_alias_set != 0
10221 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
10222 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
10223 target_alias_set)))
10224 {
10225 post_error_ne ("?possible aliasing problem for type&",
10226 gnat_node, Target_Type (gnat_node));
10227 post_error ("\\?use -fno-strict-aliasing switch for references",
10228 gnat_node);
10229 }
10230 }
10231 }
10232
10233 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
10234 source code location and false if it doesn't. If CLEAR_COLUMN is
10235 true, set the column information to 0. If DECL is given and SLOC
10236 refers to a File with an instance, map DECL to that instance. */
10237
10238 bool
Sloc_to_locus(Source_Ptr Sloc,location_t * locus,bool clear_column,const_tree decl)10239 Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column,
10240 const_tree decl)
10241 {
10242 if (Sloc == No_Location)
10243 return false;
10244
10245 if (Sloc <= Standard_Location)
10246 {
10247 *locus = BUILTINS_LOCATION;
10248 return false;
10249 }
10250
10251 Source_File_Index file = Get_Source_File_Index (Sloc);
10252 Line_Number_Type line = Get_Logical_Line_Number (Sloc);
10253 Column_Number_Type column = (clear_column ? 0 : Get_Column_Number (Sloc));
10254 line_map_ordinary *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
10255
10256 /* We can have zero if pragma Source_Reference is in effect. */
10257 if (line < 1)
10258 line = 1;
10259
10260 /* Translate the location. */
10261 *locus
10262 = linemap_position_for_line_and_column (line_table, map, line, column);
10263
10264 if (file_map && file_map[file - 1].Instance)
10265 decl_to_instance_map->put (decl, file_map[file - 1].Instance);
10266
10267 return true;
10268 }
10269
10270 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
10271 from the parameter association for the instantiation of a generic. We do
10272 not want to emit source location for them: the code generated for their
10273 initialization is likely to disturb debugging. */
10274
10275 bool
renaming_from_instantiation_p(Node_Id gnat_node)10276 renaming_from_instantiation_p (Node_Id gnat_node)
10277 {
10278 if (Nkind (gnat_node) != N_Defining_Identifier
10279 || !Is_Object (gnat_node)
10280 || Comes_From_Source (gnat_node)
10281 || !Present (Renamed_Object (gnat_node)))
10282 return false;
10283
10284 /* Get the object declaration of the renamed object, if any and if the
10285 renamed object is a mere identifier. */
10286 gnat_node = Renamed_Object (gnat_node);
10287 if (Nkind (gnat_node) != N_Identifier)
10288 return false;
10289
10290 gnat_node = Parent (Entity (gnat_node));
10291 return (Present (gnat_node)
10292 && Nkind (gnat_node) == N_Object_Declaration
10293 && Present (Corresponding_Generic_Association (gnat_node)));
10294 }
10295
10296 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
10297 don't do anything if it doesn't correspond to a source location. And,
10298 if CLEAR_COLUMN is true, set the column information to 0. */
10299
10300 static void
set_expr_location_from_node(tree node,Node_Id gnat_node,bool clear_column)10301 set_expr_location_from_node (tree node, Node_Id gnat_node, bool clear_column)
10302 {
10303 location_t locus;
10304
10305 /* Do not set a location for constructs likely to disturb debugging. */
10306 if (Nkind (gnat_node) == N_Defining_Identifier)
10307 {
10308 if (Is_Type (gnat_node) && Is_Actual_Subtype (gnat_node))
10309 return;
10310
10311 if (renaming_from_instantiation_p (gnat_node))
10312 return;
10313 }
10314
10315 if (!Sloc_to_locus (Sloc (gnat_node), &locus, clear_column))
10316 return;
10317
10318 SET_EXPR_LOCATION (node, locus);
10319 }
10320
10321 /* More elaborate version of set_expr_location_from_node to be used in more
10322 general contexts, for example the result of the translation of a generic
10323 GNAT node. */
10324
10325 static void
set_gnu_expr_location_from_node(tree node,Node_Id gnat_node)10326 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
10327 {
10328 /* Set the location information on the node if it is a real expression.
10329 References can be reused for multiple GNAT nodes and they would get
10330 the location information of their last use. Also make sure not to
10331 overwrite an existing location as it is probably more precise. */
10332
10333 switch (TREE_CODE (node))
10334 {
10335 CASE_CONVERT:
10336 case NON_LVALUE_EXPR:
10337 case SAVE_EXPR:
10338 break;
10339
10340 case COMPOUND_EXPR:
10341 if (EXPR_P (TREE_OPERAND (node, 1)))
10342 set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
10343
10344 /* ... fall through ... */
10345
10346 default:
10347 if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
10348 {
10349 set_expr_location_from_node (node, gnat_node);
10350 set_end_locus_from_node (node, gnat_node);
10351 }
10352 break;
10353 }
10354 }
10355
10356 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
10357 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
10358 most sense. Return true if a sensible assignment was performed. */
10359
10360 static bool
set_end_locus_from_node(tree gnu_node,Node_Id gnat_node)10361 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
10362 {
10363 Node_Id gnat_end_label;
10364 location_t end_locus;
10365
10366 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
10367 end_locus when there is one. We consider only GNAT nodes with a possible
10368 End_Label attached. If the End_Label actually was unassigned, fallback
10369 on the original node. We'd better assign an explicit sloc associated with
10370 the outer construct in any case. */
10371
10372 switch (Nkind (gnat_node))
10373 {
10374 case N_Package_Body:
10375 case N_Subprogram_Body:
10376 case N_Block_Statement:
10377 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
10378 break;
10379
10380 case N_Package_Declaration:
10381 gnat_end_label = End_Label (Specification (gnat_node));
10382 break;
10383
10384 default:
10385 return false;
10386 }
10387
10388 if (Present (gnat_end_label))
10389 gnat_node = gnat_end_label;
10390
10391 /* Some expanded subprograms have neither an End_Label nor a Sloc
10392 attached. Notify that to callers. For a block statement with no
10393 End_Label, clear column information, so that the tree for a
10394 transient block does not receive the sloc of a source condition. */
10395 if (!Sloc_to_locus (Sloc (gnat_node), &end_locus,
10396 No (gnat_end_label)
10397 && (Nkind (gnat_node) == N_Block_Statement)))
10398 return false;
10399
10400 switch (TREE_CODE (gnu_node))
10401 {
10402 case BIND_EXPR:
10403 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
10404 return true;
10405
10406 case FUNCTION_DECL:
10407 DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
10408 return true;
10409
10410 default:
10411 return false;
10412 }
10413 }
10414
10415 /* Post an error message. MSG is the error message, properly annotated.
10416 NODE is the node at which to post the error and the node to use for the
10417 '&' substitution. */
10418
10419 void
post_error(const char * msg,Node_Id node)10420 post_error (const char *msg, Node_Id node)
10421 {
10422 String_Template temp;
10423 String_Pointer sp;
10424
10425 if (No (node))
10426 return;
10427
10428 temp.Low_Bound = 1;
10429 temp.High_Bound = strlen (msg);
10430 sp.Bounds = &temp;
10431 sp.Array = msg;
10432 Error_Msg_N (sp, node);
10433 }
10434
10435 /* Similar to post_error, but NODE is the node at which to post the error and
10436 ENT is the node to use for the '&' substitution. */
10437
10438 void
post_error_ne(const char * msg,Node_Id node,Entity_Id ent)10439 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
10440 {
10441 String_Template temp;
10442 String_Pointer sp;
10443
10444 if (No (node))
10445 return;
10446
10447 temp.Low_Bound = 1;
10448 temp.High_Bound = strlen (msg);
10449 sp.Bounds = &temp;
10450 sp.Array = msg;
10451 Error_Msg_NE (sp, node, ent);
10452 }
10453
10454 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
10455
10456 void
post_error_ne_num(const char * msg,Node_Id node,Entity_Id ent,int num)10457 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
10458 {
10459 Error_Msg_Uint_1 = UI_From_Int (num);
10460 post_error_ne (msg, node, ent);
10461 }
10462
10463 /* Similar to post_error_ne, but T is a GCC tree representing the number to
10464 write. If T represents a constant, the text inside curly brackets in
10465 MSG will be output (presumably including a '^'). Otherwise it will not
10466 be output and the text inside square brackets will be output instead. */
10467
10468 void
post_error_ne_tree(const char * msg,Node_Id node,Entity_Id ent,tree t)10469 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
10470 {
10471 char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
10472 char start_yes, end_yes, start_no, end_no;
10473 const char *p;
10474 char *q;
10475
10476 if (TREE_CODE (t) == INTEGER_CST)
10477 {
10478 Error_Msg_Uint_1 = UI_From_gnu (t);
10479 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
10480 }
10481 else
10482 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
10483
10484 for (p = msg, q = new_msg; *p; p++)
10485 {
10486 if (*p == start_yes)
10487 for (p++; *p != end_yes; p++)
10488 *q++ = *p;
10489 else if (*p == start_no)
10490 for (p++; *p != end_no; p++)
10491 ;
10492 else
10493 *q++ = *p;
10494 }
10495
10496 *q = 0;
10497
10498 post_error_ne (new_msg, node, ent);
10499 }
10500
10501 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
10502
10503 void
post_error_ne_tree_2(const char * msg,Node_Id node,Entity_Id ent,tree t,int num)10504 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
10505 int num)
10506 {
10507 Error_Msg_Uint_2 = UI_From_Int (num);
10508 post_error_ne_tree (msg, node, ent, t);
10509 }
10510
10511 /* Return a label to branch to for the exception type in KIND or Empty
10512 if none. */
10513
10514 Entity_Id
get_exception_label(char kind)10515 get_exception_label (char kind)
10516 {
10517 switch (kind)
10518 {
10519 case N_Raise_Constraint_Error:
10520 return gnu_constraint_error_label_stack.last ();
10521
10522 case N_Raise_Storage_Error:
10523 return gnu_storage_error_label_stack.last ();
10524
10525 case N_Raise_Program_Error:
10526 return gnu_program_error_label_stack.last ();
10527
10528 default:
10529 return Empty;
10530 }
10531
10532 gcc_unreachable ();
10533 }
10534
10535 /* Return the decl for the current elaboration procedure. */
10536
10537 static tree
get_elaboration_procedure(void)10538 get_elaboration_procedure (void)
10539 {
10540 return gnu_elab_proc_stack->last ();
10541 }
10542
10543 /* Return the controlling type of a dispatching subprogram. */
10544
10545 static Entity_Id
get_controlling_type(Entity_Id subprog)10546 get_controlling_type (Entity_Id subprog)
10547 {
10548 /* This is modeled on Expand_Interface_Thunk. */
10549 Entity_Id controlling_type = Etype (First_Formal (subprog));
10550 if (Is_Access_Type (controlling_type))
10551 controlling_type = Directly_Designated_Type (controlling_type);
10552 controlling_type = Underlying_Type (controlling_type);
10553 if (Is_Concurrent_Type (controlling_type))
10554 controlling_type = Corresponding_Record_Type (controlling_type);
10555 controlling_type = Base_Type (controlling_type);
10556 return controlling_type;
10557 }
10558
10559 /* Return whether we should use an alias for the TARGET of a thunk
10560 in order to make the call generated in the thunk local. */
10561
10562 static bool
use_alias_for_thunk_p(tree target)10563 use_alias_for_thunk_p (tree target)
10564 {
10565 /* We cannot generate a local call in this case. */
10566 if (DECL_EXTERNAL (target))
10567 return false;
10568
10569 /* The call is already local in this case. */
10570 if (TREE_CODE (DECL_CONTEXT (target)) == FUNCTION_DECL)
10571 return false;
10572
10573 return TARGET_USE_LOCAL_THUNK_ALIAS_P (target);
10574 }
10575
10576 static GTY(()) unsigned long thunk_labelno = 0;
10577
10578 /* Create an alias for TARGET to be used as the target of a thunk. */
10579
10580 static tree
make_alias_for_thunk(tree target)10581 make_alias_for_thunk (tree target)
10582 {
10583 char buf[64];
10584 targetm.asm_out.generate_internal_label (buf, "LTHUNK", thunk_labelno++);
10585
10586 tree alias = build_decl (DECL_SOURCE_LOCATION (target), TREE_CODE (target),
10587 get_identifier (buf), TREE_TYPE (target));
10588
10589 DECL_LANG_SPECIFIC (alias) = DECL_LANG_SPECIFIC (target);
10590 DECL_CONTEXT (alias) = DECL_CONTEXT (target);
10591 TREE_READONLY (alias) = TREE_READONLY (target);
10592 TREE_THIS_VOLATILE (alias) = TREE_THIS_VOLATILE (target);
10593 DECL_ARTIFICIAL (alias) = 1;
10594 DECL_INITIAL (alias) = error_mark_node;
10595 DECL_ARGUMENTS (alias) = copy_list (DECL_ARGUMENTS (target));
10596 TREE_ADDRESSABLE (alias) = 1;
10597 SET_DECL_ASSEMBLER_NAME (alias, DECL_NAME (alias));
10598
10599 cgraph_node *n = cgraph_node::create_same_body_alias (alias, target);
10600 gcc_assert (n);
10601
10602 return alias;
10603 }
10604
10605 /* Create the local covariant part of {GNAT,GNU}_THUNK. */
10606
10607 static tree
make_covariant_thunk(Entity_Id gnat_thunk,tree gnu_thunk)10608 make_covariant_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
10609 {
10610 tree gnu_name = create_concat_name (gnat_thunk, "CV");
10611 tree gnu_cv_thunk
10612 = build_decl (DECL_SOURCE_LOCATION (gnu_thunk), TREE_CODE (gnu_thunk),
10613 gnu_name, TREE_TYPE (gnu_thunk));
10614
10615 DECL_ARGUMENTS (gnu_cv_thunk) = copy_list (DECL_ARGUMENTS (gnu_thunk));
10616 for (tree param_decl = DECL_ARGUMENTS (gnu_cv_thunk);
10617 param_decl;
10618 param_decl = DECL_CHAIN (param_decl))
10619 DECL_CONTEXT (param_decl) = gnu_cv_thunk;
10620
10621 DECL_RESULT (gnu_cv_thunk) = copy_node (DECL_RESULT (gnu_thunk));
10622 DECL_CONTEXT (DECL_RESULT (gnu_cv_thunk)) = gnu_cv_thunk;
10623
10624 DECL_LANG_SPECIFIC (gnu_cv_thunk) = DECL_LANG_SPECIFIC (gnu_thunk);
10625 DECL_CONTEXT (gnu_cv_thunk) = DECL_CONTEXT (gnu_thunk);
10626 TREE_READONLY (gnu_cv_thunk) = TREE_READONLY (gnu_thunk);
10627 TREE_THIS_VOLATILE (gnu_cv_thunk) = TREE_THIS_VOLATILE (gnu_thunk);
10628 DECL_ARTIFICIAL (gnu_cv_thunk) = 1;
10629
10630 return gnu_cv_thunk;
10631 }
10632
10633 /* Try to create a GNU thunk for {GNAT,GNU}_THUNK and return true on success.
10634
10635 GNU thunks are more efficient than GNAT thunks because they don't call into
10636 the runtime to retrieve the offset used in the displacement operation, but
10637 they are tailored to C++ and thus too limited to support the full range of
10638 thunks generated in Ada. Here's the complete list of limitations:
10639
10640 1. Multi-controlling thunks, i.e thunks with more than one controlling
10641 parameter, are simply not supported.
10642
10643 2. Covariant thunks, i.e. thunks for which the result is also controlling,
10644 are split into a pair of (this, covariant-only) thunks.
10645
10646 3. Variable-offset thunks, i.e. thunks for which the offset depends on the
10647 object and not only on its type, are supported as 2nd class citizens.
10648
10649 4. External thunks, i.e. thunks for which the target is not declared in
10650 the same unit as the thunk, are supported as 2nd class citizens.
10651
10652 5. Local thunks, i.e. thunks generated for a local type, are supported as
10653 2nd class citizens. */
10654
10655 static bool
maybe_make_gnu_thunk(Entity_Id gnat_thunk,tree gnu_thunk)10656 maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
10657 {
10658 const Entity_Id gnat_target = Thunk_Entity (gnat_thunk);
10659
10660 /* Check that the first formal of the target is the only controlling one. */
10661 Entity_Id gnat_formal = First_Formal (gnat_target);
10662 if (!Is_Controlling_Formal (gnat_formal))
10663 return false;
10664 for (gnat_formal = Next_Formal (gnat_formal);
10665 Present (gnat_formal);
10666 gnat_formal = Next_Formal (gnat_formal))
10667 if (Is_Controlling_Formal (gnat_formal))
10668 return false;
10669
10670 /* Look for the types that control the target and the thunk. */
10671 const Entity_Id gnat_controlling_type = get_controlling_type (gnat_target);
10672 const Entity_Id gnat_interface_type = get_controlling_type (gnat_thunk);
10673
10674 /* We must have an interface type at this point. */
10675 gcc_assert (Is_Interface (gnat_interface_type));
10676
10677 /* Now compute whether the former covers the latter. */
10678 const Entity_Id gnat_interface_tag
10679 = Find_Interface_Tag (gnat_controlling_type, gnat_interface_type);
10680 tree gnu_interface_tag
10681 = Present (gnat_interface_tag)
10682 ? gnat_to_gnu_field_decl (gnat_interface_tag)
10683 : NULL_TREE;
10684 tree gnu_interface_offset
10685 = gnu_interface_tag ? byte_position (gnu_interface_tag) : NULL_TREE;
10686
10687 /* There are three ways to retrieve the offset between the interface view
10688 and the base object. Either the controlling type covers the interface
10689 type and the offset of the corresponding tag is fixed, in which case it
10690 can be statically encoded in the thunk (see FIXED_OFFSET below). Or the
10691 controlling type doesn't cover the interface type but is of fixed size,
10692 in which case the offset is stored in the dispatch table, two pointers
10693 above the dispatch table address (see VIRTUAL_VALUE below). Otherwise,
10694 the offset is variable and is stored right after the tag in every object
10695 (see INDIRECT_OFFSET below). See also a-tags.ads for more details. */
10696 HOST_WIDE_INT fixed_offset, virtual_value, indirect_offset;
10697 tree virtual_offset;
10698
10699 if (gnu_interface_offset && TREE_CODE (gnu_interface_offset) == INTEGER_CST)
10700 {
10701 fixed_offset = - tree_to_shwi (gnu_interface_offset);
10702 virtual_value = 0;
10703 virtual_offset = NULL_TREE;
10704 indirect_offset = 0;
10705 }
10706 else if (!gnu_interface_offset
10707 && !Is_Variable_Size_Record (gnat_controlling_type))
10708 {
10709 fixed_offset = 0;
10710 virtual_value = - 2 * (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
10711 virtual_offset = build_int_cst (integer_type_node, virtual_value);
10712 indirect_offset = 0;
10713 }
10714 else
10715 {
10716 /* Covariant thunks with variable offset are not supported. */
10717 if (Has_Controlling_Result (gnat_target))
10718 return false;
10719
10720 fixed_offset = 0;
10721 virtual_value = 0;
10722 virtual_offset = NULL_TREE;
10723 indirect_offset = (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
10724 }
10725
10726 tree gnu_target = gnat_to_gnu_entity (gnat_target, NULL_TREE, false);
10727
10728 /* If the target is local, then thunk and target must have the same context
10729 because cgraph_node::expand_thunk can only forward the static chain. */
10730 if (DECL_STATIC_CHAIN (gnu_target)
10731 && DECL_CONTEXT (gnu_thunk) != DECL_CONTEXT (gnu_target))
10732 return false;
10733
10734 /* If the target returns by invisible reference and is external, apply the
10735 same transformation as Subprogram_Body_to_gnu here. */
10736 if (TREE_ADDRESSABLE (TREE_TYPE (gnu_target))
10737 && DECL_EXTERNAL (gnu_target)
10738 && !POINTER_TYPE_P (TREE_TYPE (DECL_RESULT (gnu_target))))
10739 {
10740 TREE_TYPE (DECL_RESULT (gnu_target))
10741 = build_reference_type (TREE_TYPE (DECL_RESULT (gnu_target)));
10742 relayout_decl (DECL_RESULT (gnu_target));
10743 }
10744
10745 /* The thunk expander requires the return types of thunk and target to be
10746 compatible, which is not fully the case with the CICO mechanism. */
10747 if (TYPE_CI_CO_LIST (TREE_TYPE (gnu_thunk)))
10748 {
10749 tree gnu_target_type = TREE_TYPE (gnu_target);
10750 gcc_assert (TYPE_CI_CO_LIST (gnu_target_type));
10751 TYPE_CANONICAL (TREE_TYPE (TREE_TYPE (gnu_thunk)))
10752 = TYPE_CANONICAL (TREE_TYPE (gnu_target_type));
10753 }
10754
10755 cgraph_node *target_node = cgraph_node::get_create (gnu_target);
10756
10757 /* We may also need to create an alias for the target in order to make
10758 the call local, depending on the linkage of the target. */
10759 tree gnu_alias = use_alias_for_thunk_p (gnu_target)
10760 ? make_alias_for_thunk (gnu_target)
10761 : gnu_target;
10762
10763 /* If the return type of the target is a controlling type, then we need
10764 both an usual this thunk and a covariant thunk in this order:
10765
10766 this thunk --> covariant thunk --> target
10767
10768 For covariant thunks, we can only handle a fixed offset. */
10769 if (Has_Controlling_Result (gnat_target))
10770 {
10771 gcc_assert (fixed_offset < 0);
10772 tree gnu_cv_thunk = make_covariant_thunk (gnat_thunk, gnu_thunk);
10773 target_node->create_thunk (gnu_cv_thunk, gnu_target, false,
10774 - fixed_offset, 0, 0,
10775 NULL_TREE, gnu_alias);
10776
10777 gnu_alias = gnu_target = gnu_cv_thunk;
10778 }
10779
10780 target_node->create_thunk (gnu_thunk, gnu_target, true,
10781 fixed_offset, virtual_value, indirect_offset,
10782 virtual_offset, gnu_alias);
10783
10784 return true;
10785 }
10786
10787 /* Initialize the table that maps GNAT codes to GCC codes for simple
10788 binary and unary operations. */
10789
10790 static void
init_code_table(void)10791 init_code_table (void)
10792 {
10793 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
10794 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
10795 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
10796 gnu_codes[N_Op_Eq] = EQ_EXPR;
10797 gnu_codes[N_Op_Ne] = NE_EXPR;
10798 gnu_codes[N_Op_Lt] = LT_EXPR;
10799 gnu_codes[N_Op_Le] = LE_EXPR;
10800 gnu_codes[N_Op_Gt] = GT_EXPR;
10801 gnu_codes[N_Op_Ge] = GE_EXPR;
10802 gnu_codes[N_Op_Add] = PLUS_EXPR;
10803 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
10804 gnu_codes[N_Op_Multiply] = MULT_EXPR;
10805 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
10806 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
10807 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
10808 gnu_codes[N_Op_Abs] = ABS_EXPR;
10809 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
10810 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
10811 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
10812 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
10813 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
10814 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
10815 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
10816 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
10817 }
10818
10819 #include "gt-ada-trans.h"
10820