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