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