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