[21/77] Replace SCALAR_INT_MODE_P checks with is_a <scalar_int_mode>
[official-gcc.git] / gcc / ada / gcc-interface / trans.c
blob693c74f2a084355c54a56f7992ee7ad36167f20b
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
20 * *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
23 * *
24 ****************************************************************************/
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "target.h"
30 #include "function.h"
31 #include "bitmap.h"
32 #include "tree.h"
33 #include "gimple-expr.h"
34 #include "stringpool.h"
35 #include "cgraph.h"
36 #include "predict.h"
37 #include "diagnostic.h"
38 #include "alias.h"
39 #include "fold-const.h"
40 #include "stor-layout.h"
41 #include "stmt.h"
42 #include "varasm.h"
43 #include "output.h"
44 #include "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"
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"
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
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;
85 /* Highest number in the front-end node table. */
86 int max_gnat_nodes;
88 /* Current node being treated, in case abort called. */
89 Node_Id error_gnat_node;
91 /* True when gigi is being called on an analyzed but unexpanded
92 tree, and the only purpose of the call is to properly annotate
93 types with representation information. */
94 bool type_annotate_only;
96 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
97 static vec<Node_Id> gnat_validate_uc_list;
99 /* 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;
110 typedef struct parm_attr_d *parm_attr;
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;
120 #define f_parm_attr_cache \
121 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
123 #define f_named_ret_val \
124 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
126 #define f_other_ret_val \
127 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
129 #define f_gnat_ret \
130 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
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. */
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. */
144 static GTY(()) struct stmt_group *current_stmt_group;
146 /* List of unused struct stmt_group nodes. */
147 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
149 /* A structure used to record information on elaboration procedures
150 we've made and need to process.
152 ??? gnat_node should be Node_Id, but gengtype gets confused. */
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. */
160 static GTY(()) struct elab_info *elab_info_list;
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;
167 /* In ZCX case, current exception pointer. Used to re-raise it. */
168 static GTY(()) tree gnu_incoming_exc_ptr;
170 /* Stack for storing the current elaboration procedure decl. */
171 static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack;
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;
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;
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;
192 typedef struct range_check_info_d *range_check_info;
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 bool artificial;
203 bool has_checks;
204 bool warned_aggressive_loop_optimizations;
207 typedef struct loop_info_d *loop_info;
210 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
211 static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
213 /* The stacks for N_{Push,Pop}_*_Label. */
214 static GTY(()) vec<tree, va_gc> *gnu_constraint_error_label_stack;
215 static GTY(()) vec<tree, va_gc> *gnu_storage_error_label_stack;
216 static GTY(()) vec<tree, va_gc> *gnu_program_error_label_stack;
218 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
219 static enum tree_code gnu_codes[Number_Node_Kinds];
221 static void init_code_table (void);
222 static tree get_elaboration_procedure (void);
223 static void Compilation_Unit_to_gnu (Node_Id);
224 static bool empty_stmt_list_p (tree);
225 static void record_code_position (Node_Id);
226 static void insert_code_for (Node_Id);
227 static void add_cleanup (tree, Node_Id);
228 static void add_stmt_list (List_Id);
229 static void push_exception_label_stack (vec<tree, va_gc> **, Entity_Id);
230 static tree build_stmt_group (List_Id, bool);
231 static inline bool stmt_group_may_fallthru (void);
232 static enum gimplify_status gnat_gimplify_stmt (tree *);
233 static void elaborate_all_entities (Node_Id);
234 static void process_freeze_entity (Node_Id);
235 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
236 static tree emit_range_check (tree, Node_Id, Node_Id);
237 static tree emit_check (tree, tree, int, Node_Id);
238 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
239 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
240 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
241 static bool addressable_p (tree, tree);
242 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
243 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
244 static void validate_unchecked_conversion (Node_Id);
245 static tree maybe_implicit_deref (tree);
246 static void set_expr_location_from_node (tree, Node_Id, bool = false);
247 static void set_gnu_expr_location_from_node (tree, Node_Id);
248 static bool set_end_locus_from_node (tree, Node_Id);
249 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
250 static tree build_raise_check (int, enum exception_info_kind);
251 static tree create_init_temporary (const char *, tree, tree *, Node_Id);
253 /* Hooks for debug info back-ends, only supported and used in a restricted set
254 of configurations. */
255 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
256 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
258 /* This is the main program of the back-end. It sets up all the table
259 structures and then generates code. */
261 void
262 gigi (Node_Id gnat_root,
263 int max_gnat_node,
264 int number_name ATTRIBUTE_UNUSED,
265 struct Node *nodes_ptr,
266 struct Flags *flags_ptr,
267 Node_Id *next_node_ptr,
268 Node_Id *prev_node_ptr,
269 struct Elist_Header *elists_ptr,
270 struct Elmt_Item *elmts_ptr,
271 struct String_Entry *strings_ptr,
272 Char_Code *string_chars_ptr,
273 struct List_Header *list_headers_ptr,
274 Nat number_file,
275 struct File_Info_Type *file_info_ptr,
276 Entity_Id standard_boolean,
277 Entity_Id standard_integer,
278 Entity_Id standard_character,
279 Entity_Id standard_long_long_float,
280 Entity_Id standard_exception_type,
281 Int gigi_operating_mode)
283 Node_Id gnat_iter;
284 Entity_Id gnat_literal;
285 tree t, ftype, int64_type;
286 struct elab_info *info;
287 int i;
289 max_gnat_nodes = max_gnat_node;
291 Nodes_Ptr = nodes_ptr;
292 Flags_Ptr = flags_ptr;
293 Next_Node_Ptr = next_node_ptr;
294 Prev_Node_Ptr = prev_node_ptr;
295 Elists_Ptr = elists_ptr;
296 Elmts_Ptr = elmts_ptr;
297 Strings_Ptr = strings_ptr;
298 String_Chars_Ptr = string_chars_ptr;
299 List_Headers_Ptr = list_headers_ptr;
301 type_annotate_only = (gigi_operating_mode == 1);
303 for (i = 0; i < number_file; i++)
305 /* Use the identifier table to make a permanent copy of the filename as
306 the name table gets reallocated after Gigi returns but before all the
307 debugging information is output. The __gnat_to_canonical_file_spec
308 call translates filenames from pragmas Source_Reference that contain
309 host style syntax not understood by gdb. */
310 const char *filename
311 = IDENTIFIER_POINTER
312 (get_identifier
313 (__gnat_to_canonical_file_spec
314 (Get_Name_String (file_info_ptr[i].File_Name))));
316 /* We rely on the order isomorphism between files and line maps. */
317 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i);
319 /* We create the line map for a source file at once, with a fixed number
320 of columns chosen to avoid jumping over the next power of 2. */
321 linemap_add (line_table, LC_ENTER, 0, filename, 1);
322 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
323 linemap_position_for_column (line_table, 252 - 1);
324 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
327 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
329 /* Declare the name of the compilation unit as the first global
330 name in order to make the middle-end fully deterministic. */
331 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
332 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
334 /* Initialize ourselves. */
335 init_code_table ();
336 init_gnat_decl ();
337 init_gnat_utils ();
339 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
340 errors. */
341 if (type_annotate_only)
343 TYPE_SIZE (void_type_node) = bitsize_zero_node;
344 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
347 /* Enable GNAT stack checking method if needed */
348 if (!Stack_Check_Probes_On_Target)
349 set_stack_check_libfunc ("_gnat_stack_check");
351 /* Retrieve alignment settings. */
352 double_float_alignment = get_target_double_float_alignment ();
353 double_scalar_alignment = get_target_double_scalar_alignment ();
355 /* Record the builtin types. Define `integer' and `character' first so that
356 dbx will output them first. */
357 record_builtin_type ("integer", integer_type_node, false);
358 record_builtin_type ("character", char_type_node, false);
359 record_builtin_type ("boolean", boolean_type_node, false);
360 record_builtin_type ("void", void_type_node, false);
362 /* Save the type we made for integer as the type for Standard.Integer. */
363 save_gnu_tree (Base_Type (standard_integer),
364 TYPE_NAME (integer_type_node),
365 false);
367 /* Likewise for character as the type for Standard.Character. */
368 finish_character_type (char_type_node);
369 save_gnu_tree (Base_Type (standard_character),
370 TYPE_NAME (char_type_node),
371 false);
373 /* Likewise for boolean as the type for Standard.Boolean. */
374 save_gnu_tree (Base_Type (standard_boolean),
375 TYPE_NAME (boolean_type_node),
376 false);
377 gnat_literal = First_Literal (Base_Type (standard_boolean));
378 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
379 gcc_assert (t == boolean_false_node);
380 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
381 boolean_type_node, t, true, false, false, false, false,
382 true, false, NULL, gnat_literal);
383 save_gnu_tree (gnat_literal, t, false);
384 gnat_literal = Next_Literal (gnat_literal);
385 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
386 gcc_assert (t == boolean_true_node);
387 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
388 boolean_type_node, t, true, false, false, false, false,
389 true, false, NULL, gnat_literal);
390 save_gnu_tree (gnat_literal, t, false);
392 /* Declare the building blocks of function nodes. */
393 void_list_node = build_tree_list (NULL_TREE, void_type_node);
394 void_ftype = build_function_type_list (void_type_node, NULL_TREE);
395 ptr_void_ftype = build_pointer_type (void_ftype);
397 /* Now declare run-time functions. */
398 ftype = build_function_type_list (ptr_type_node, sizetype, NULL_TREE);
399 malloc_decl
400 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
401 ftype,
402 NULL_TREE, is_disabled, true, true, true, false,
403 false, NULL, Empty);
404 DECL_IS_MALLOC (malloc_decl) = 1;
406 ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
407 free_decl
408 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
409 ftype,
410 NULL_TREE, is_disabled, true, true, true, false,
411 false, NULL, Empty);
413 ftype = build_function_type_list (ptr_type_node, ptr_type_node, sizetype,
414 NULL_TREE);
415 realloc_decl
416 = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE,
417 ftype,
418 NULL_TREE, is_disabled, true, true, true, false,
419 false, NULL, Empty);
421 /* This is used for 64-bit multiplication with overflow checking. */
422 int64_type = gnat_type_for_size (64, 0);
423 mulv64_decl
424 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
425 build_function_type_list (int64_type, int64_type,
426 int64_type, NULL_TREE),
427 NULL_TREE, is_disabled, true, true, true, false,
428 false, NULL, Empty);
430 /* Name of the _Parent field in tagged record types. */
431 parent_name_id = get_identifier (Get_Name_String (Name_uParent));
433 /* Name of the Exception_Data type defined in System.Standard_Library. */
434 exception_data_name_id
435 = get_identifier ("system__standard_library__exception_data");
437 /* Make the types and functions used for exception processing. */
438 except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type));
440 jmpbuf_type
441 = build_array_type (gnat_type_for_mode (Pmode, 0),
442 build_index_type (size_int (5)));
443 record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
444 jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
446 /* Functions to get and set the jumpbuf pointer for the current thread. */
447 get_jmpbuf_decl
448 = create_subprog_decl
449 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
450 NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
451 NULL_TREE, is_disabled, true, true, true, false, false, NULL, Empty);
453 set_jmpbuf_decl
454 = create_subprog_decl
455 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
456 NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
457 NULL_TREE),
458 NULL_TREE, is_disabled, true, true, true, false, false, NULL, Empty);
460 get_excptr_decl
461 = create_subprog_decl
462 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
463 build_function_type_list (build_pointer_type (except_type_node),
464 NULL_TREE),
465 NULL_TREE, is_disabled, true, true, true, false, false, NULL, Empty);
467 not_handled_by_others_decl = get_identifier ("not_handled_by_others");
468 for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
469 if (DECL_NAME (t) == not_handled_by_others_decl)
471 not_handled_by_others_decl = t;
472 break;
474 gcc_assert (DECL_P (not_handled_by_others_decl));
476 /* setjmp returns an integer and has one operand, which is a pointer to
477 a jmpbuf. */
478 setjmp_decl
479 = create_subprog_decl
480 (get_identifier ("__builtin_setjmp"), NULL_TREE,
481 build_function_type_list (integer_type_node, jmpbuf_ptr_type,
482 NULL_TREE),
483 NULL_TREE, is_disabled, true, true, true, false, false, NULL, Empty);
484 DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
485 DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
487 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
488 address. */
489 update_setjmp_buf_decl
490 = create_subprog_decl
491 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
492 build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
493 NULL_TREE, is_disabled, true, true, true, false, false, NULL, Empty);
494 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
495 DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
497 /* Indicate that it never returns. */
498 ftype = build_function_type_list (void_type_node,
499 build_pointer_type (except_type_node),
500 NULL_TREE);
501 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
502 raise_nodefer_decl
503 = create_subprog_decl
504 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, ftype,
505 NULL_TREE, is_disabled, true, true, true, false, false, NULL, Empty);
507 set_exception_parameter_decl
508 = create_subprog_decl
509 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
510 build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
511 NULL_TREE),
512 NULL_TREE, is_disabled, true, true, true, false, false, NULL, Empty);
514 /* Hooks to call when entering/leaving an exception handler. */
515 ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
517 begin_handler_decl
518 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
519 ftype, NULL_TREE,
520 is_disabled, true, true, true, false, false, NULL,
521 Empty);
522 /* __gnat_begin_handler is a dummy procedure. */
523 TREE_NOTHROW (begin_handler_decl) = 1;
525 end_handler_decl
526 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
527 ftype, NULL_TREE,
528 is_disabled, true, true, true, false, false, NULL,
529 Empty);
531 unhandled_except_decl
532 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
533 NULL_TREE, ftype, NULL_TREE,
534 is_disabled, true, true, true, false, false, NULL,
535 Empty);
537 /* Indicate that it never returns. */
538 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
539 reraise_zcx_decl
540 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
541 ftype, NULL_TREE,
542 is_disabled, true, true, true, false, false, NULL,
543 Empty);
545 /* Dummy objects to materialize "others" and "all others" in the exception
546 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
547 the types to use. */
548 others_decl
549 = create_var_decl (get_identifier ("OTHERS"),
550 get_identifier ("__gnat_others_value"),
551 char_type_node, NULL_TREE,
552 true, false, true, false, false, true, false,
553 NULL, Empty);
555 all_others_decl
556 = create_var_decl (get_identifier ("ALL_OTHERS"),
557 get_identifier ("__gnat_all_others_value"),
558 char_type_node, NULL_TREE,
559 true, false, true, false, false, true, false,
560 NULL, Empty);
562 unhandled_others_decl
563 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
564 get_identifier ("__gnat_unhandled_others_value"),
565 char_type_node, NULL_TREE,
566 true, false, true, false, false, true, false,
567 NULL, Empty);
569 /* If in no exception handlers mode, all raise statements are redirected to
570 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
571 this procedure will never be called in this mode. */
572 if (No_Exception_Handlers_Set ())
574 /* Indicate that it never returns. */
575 ftype = build_function_type_list (void_type_node,
576 build_pointer_type (char_type_node),
577 integer_type_node, NULL_TREE);
578 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
579 tree decl
580 = create_subprog_decl
581 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, ftype,
582 NULL_TREE, is_disabled, true, true, true, false, false, NULL,
583 Empty);
584 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
585 gnat_raise_decls[i] = decl;
587 else
589 /* Otherwise, make one decl for each exception reason. */
590 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
591 gnat_raise_decls[i] = build_raise_check (i, exception_simple);
592 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
593 gnat_raise_decls_ext[i]
594 = build_raise_check (i,
595 i == CE_Index_Check_Failed
596 || i == CE_Range_Check_Failed
597 || i == CE_Invalid_Data
598 ? exception_range : exception_column);
601 /* Build the special descriptor type and its null node if needed. */
602 if (TARGET_VTABLE_USES_DESCRIPTORS)
604 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
605 tree field_list = NULL_TREE;
606 int j;
607 vec<constructor_elt, va_gc> *null_vec = NULL;
608 constructor_elt *elt;
610 fdesc_type_node = make_node (RECORD_TYPE);
611 vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS);
612 elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
614 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
616 tree field
617 = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
618 NULL_TREE, NULL_TREE, 0, 1);
619 DECL_CHAIN (field) = field_list;
620 field_list = field;
621 elt->index = field;
622 elt->value = null_node;
623 elt--;
626 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
627 record_builtin_type ("descriptor", fdesc_type_node, true);
628 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
631 longest_float_type_node
632 = get_unpadded_type (Base_Type (standard_long_long_float));
634 main_identifier_node = get_identifier ("main");
636 /* If we are using the GCC exception mechanism, let GCC know. */
637 if (Back_End_Exceptions ())
638 gnat_init_gcc_eh ();
640 /* Initialize the GCC support for FP operations. */
641 gnat_init_gcc_fp ();
643 /* Install the builtins we might need, either internally or as user-available
644 facilities for Intrinsic imports. Note that this must be done after the
645 GCC exception mechanism is initialized. */
646 gnat_install_builtins ();
648 vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
649 vec_safe_push (gnu_constraint_error_label_stack, NULL_TREE);
650 vec_safe_push (gnu_storage_error_label_stack, NULL_TREE);
651 vec_safe_push (gnu_program_error_label_stack, NULL_TREE);
653 /* Process any Pragma Ident for the main unit. */
654 if (Present (Ident_String (Main_Unit)))
655 targetm.asm_out.output_ident
656 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
658 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
659 if (No_Strict_Aliasing_CP)
660 flag_strict_aliasing = 0;
662 /* Save the current optimization options again after the above possible
663 global_options changes. */
664 optimization_default_node = build_optimization_node (&global_options);
665 optimization_current_node = optimization_default_node;
667 /* Now translate the compilation unit proper. */
668 Compilation_Unit_to_gnu (gnat_root);
670 /* Disable -Waggressive-loop-optimizations since we implement our own
671 version of the warning. */
672 warn_aggressive_loop_optimizations = 0;
674 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
675 the very end to avoid having to second-guess the front-end when we run
676 into dummy nodes during the regular processing. */
677 for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++)
678 validate_unchecked_conversion (gnat_iter);
679 gnat_validate_uc_list.release ();
681 /* Finally see if we have any elaboration procedures to deal with. */
682 for (info = elab_info_list; info; info = info->next)
684 tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
686 /* We should have a BIND_EXPR but it may not have any statements in it.
687 If it doesn't have any, we have nothing to do except for setting the
688 flag on the GNAT node. Otherwise, process the function as others. */
689 tree gnu_stmts = gnu_body;
690 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
691 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
692 if (!gnu_stmts || empty_stmt_list_p (gnu_stmts))
693 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
694 else
696 begin_subprog_body (info->elab_proc);
697 end_subprog_body (gnu_body);
698 rest_of_subprog_body_compilation (info->elab_proc);
702 /* Destroy ourselves. */
703 destroy_gnat_decl ();
704 destroy_gnat_utils ();
706 /* We cannot track the location of errors past this point. */
707 error_gnat_node = Empty;
710 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
711 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
713 static tree
714 build_raise_check (int check, enum exception_info_kind kind)
716 tree result, ftype;
717 const char pfx[] = "__gnat_rcheck_";
719 strcpy (Name_Buffer, pfx);
720 Name_Len = sizeof (pfx) - 1;
721 Get_RT_Exception_Name (check);
723 if (kind == exception_simple)
725 Name_Buffer[Name_Len] = 0;
726 ftype
727 = build_function_type_list (void_type_node,
728 build_pointer_type (char_type_node),
729 integer_type_node, NULL_TREE);
731 else
733 tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
735 strcpy (Name_Buffer + Name_Len, "_ext");
736 Name_Buffer[Name_Len + 4] = 0;
737 ftype
738 = build_function_type_list (void_type_node,
739 build_pointer_type (char_type_node),
740 integer_type_node, integer_type_node,
741 t, t, NULL_TREE);
744 /* Indicate that it never returns. */
745 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
746 result
747 = create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, ftype,
748 NULL_TREE, is_disabled, true, true, true, false,
749 false, NULL, Empty);
751 return result;
754 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
755 an N_Attribute_Reference. */
757 static int
758 lvalue_required_for_attribute_p (Node_Id gnat_node)
760 switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
762 case Attr_Pos:
763 case Attr_Val:
764 case Attr_Pred:
765 case Attr_Succ:
766 case Attr_First:
767 case Attr_Last:
768 case Attr_Range_Length:
769 case Attr_Length:
770 case Attr_Object_Size:
771 case Attr_Value_Size:
772 case Attr_Component_Size:
773 case Attr_Descriptor_Size:
774 case Attr_Max_Size_In_Storage_Elements:
775 case Attr_Min:
776 case Attr_Max:
777 case Attr_Null_Parameter:
778 case Attr_Passed_By_Reference:
779 case Attr_Mechanism_Code:
780 case Attr_Machine:
781 case Attr_Model:
782 return 0;
784 case Attr_Address:
785 case Attr_Access:
786 case Attr_Unchecked_Access:
787 case Attr_Unrestricted_Access:
788 case Attr_Code_Address:
789 case Attr_Pool_Address:
790 case Attr_Size:
791 case Attr_Alignment:
792 case Attr_Bit_Position:
793 case Attr_Position:
794 case Attr_First_Bit:
795 case Attr_Last_Bit:
796 case Attr_Bit:
797 case Attr_Asm_Input:
798 case Attr_Asm_Output:
799 default:
800 return 1;
804 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
805 is the type that will be used for GNAT_NODE in the translated GNU tree.
806 CONSTANT indicates whether the underlying object represented by GNAT_NODE
807 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
808 whether its value is the address of a constant and ALIASED whether it is
809 aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
811 The function climbs up the GNAT tree starting from the node and returns 1
812 upon encountering a node that effectively requires an lvalue downstream.
813 It returns int instead of bool to facilitate usage in non-purely binary
814 logic contexts. */
816 static int
817 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
818 bool address_of_constant, bool aliased)
820 Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
822 switch (Nkind (gnat_parent))
824 case N_Reference:
825 return 1;
827 case N_Attribute_Reference:
828 return lvalue_required_for_attribute_p (gnat_parent);
830 case N_Parameter_Association:
831 case N_Function_Call:
832 case N_Procedure_Call_Statement:
833 /* If the parameter is by reference, an lvalue is required. */
834 return (!constant
835 || must_pass_by_ref (gnu_type)
836 || default_pass_by_ref (gnu_type));
838 case N_Indexed_Component:
839 /* Only the array expression can require an lvalue. */
840 if (Prefix (gnat_parent) != gnat_node)
841 return 0;
843 /* ??? Consider that referencing an indexed component with a variable
844 index forces the whole aggregate to memory. Note that testing only
845 for literals is conservative, any static expression in the RM sense
846 could probably be accepted with some additional work. */
847 for (gnat_temp = First (Expressions (gnat_parent));
848 Present (gnat_temp);
849 gnat_temp = Next (gnat_temp))
850 if (Nkind (gnat_temp) != N_Character_Literal
851 && Nkind (gnat_temp) != N_Integer_Literal
852 && !(Is_Entity_Name (gnat_temp)
853 && Ekind (Entity (gnat_temp)) == E_Enumeration_Literal))
854 return 1;
856 /* ... fall through ... */
858 case N_Slice:
859 /* Only the array expression can require an lvalue. */
860 if (Prefix (gnat_parent) != gnat_node)
861 return 0;
863 aliased |= Has_Aliased_Components (Etype (gnat_node));
864 return lvalue_required_p (gnat_parent, gnu_type, constant,
865 address_of_constant, aliased);
867 case N_Selected_Component:
868 aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
869 return lvalue_required_p (gnat_parent, gnu_type, constant,
870 address_of_constant, aliased);
872 case N_Object_Renaming_Declaration:
873 /* We need to preserve addresses through a renaming. */
874 return 1;
876 case N_Object_Declaration:
877 /* We cannot use a constructor if this is an atomic object because
878 the actual assignment might end up being done component-wise. */
879 return (!constant
880 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
881 && Is_Atomic_Or_VFA (Defining_Entity (gnat_parent)))
882 /* We don't use a constructor if this is a class-wide object
883 because the effective type of the object is the equivalent
884 type of the class-wide subtype and it smashes most of the
885 data into an array of bytes to which we cannot convert. */
886 || Ekind ((Etype (Defining_Entity (gnat_parent))))
887 == E_Class_Wide_Subtype);
889 case N_Assignment_Statement:
890 /* We cannot use a constructor if the LHS is an atomic object because
891 the actual assignment might end up being done component-wise. */
892 return (!constant
893 || Name (gnat_parent) == gnat_node
894 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
895 && Is_Entity_Name (Name (gnat_parent))
896 && Is_Atomic_Or_VFA (Entity (Name (gnat_parent)))));
898 case N_Unchecked_Type_Conversion:
899 if (!constant)
900 return 1;
902 /* ... fall through ... */
904 case N_Type_Conversion:
905 case N_Qualified_Expression:
906 /* We must look through all conversions because we may need to bypass
907 an intermediate conversion that is meant to be purely formal. */
908 return lvalue_required_p (gnat_parent,
909 get_unpadded_type (Etype (gnat_parent)),
910 constant, address_of_constant, aliased);
912 case N_Allocator:
913 /* We should only reach here through the N_Qualified_Expression case.
914 Force an lvalue for composite types since a block-copy to the newly
915 allocated area of memory is made. */
916 return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
918 case N_Explicit_Dereference:
919 /* We look through dereferences for address of constant because we need
920 to handle the special cases listed above. */
921 if (constant && address_of_constant)
922 return lvalue_required_p (gnat_parent,
923 get_unpadded_type (Etype (gnat_parent)),
924 true, false, true);
926 /* ... fall through ... */
928 default:
929 return 0;
932 gcc_unreachable ();
935 /* Return true if T is a constant DECL node that can be safely replaced
936 by its initializer. */
938 static bool
939 constant_decl_with_initializer_p (tree t)
941 if (!TREE_CONSTANT (t) || !DECL_P (t) || !DECL_INITIAL (t))
942 return false;
944 /* Return false for aggregate types that contain a placeholder since
945 their initializers cannot be manipulated easily. */
946 if (AGGREGATE_TYPE_P (TREE_TYPE (t))
947 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t))
948 && type_contains_placeholder_p (TREE_TYPE (t)))
949 return false;
951 return true;
954 /* Return an expression equivalent to EXP but where constant DECL nodes
955 have been replaced by their initializer. */
957 static tree
958 fold_constant_decl_in_expr (tree exp)
960 enum tree_code code = TREE_CODE (exp);
961 tree op0;
963 switch (code)
965 case CONST_DECL:
966 case VAR_DECL:
967 if (!constant_decl_with_initializer_p (exp))
968 return exp;
970 return DECL_INITIAL (exp);
972 case COMPONENT_REF:
973 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
974 if (op0 == TREE_OPERAND (exp, 0))
975 return exp;
977 return fold_build3 (COMPONENT_REF, TREE_TYPE (exp), op0,
978 TREE_OPERAND (exp, 1), NULL_TREE);
980 case BIT_FIELD_REF:
981 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
982 if (op0 == TREE_OPERAND (exp, 0))
983 return exp;
985 return fold_build3 (BIT_FIELD_REF, TREE_TYPE (exp), op0,
986 TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
988 case ARRAY_REF:
989 case ARRAY_RANGE_REF:
990 /* If the index is not itself constant, then nothing can be folded. */
991 if (!TREE_CONSTANT (TREE_OPERAND (exp, 1)))
992 return exp;
993 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
994 if (op0 == TREE_OPERAND (exp, 0))
995 return exp;
997 return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
998 TREE_OPERAND (exp, 2), NULL_TREE));
1000 case REALPART_EXPR:
1001 case IMAGPART_EXPR:
1002 case VIEW_CONVERT_EXPR:
1003 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1004 if (op0 == TREE_OPERAND (exp, 0))
1005 return exp;
1007 return fold_build1 (code, TREE_TYPE (exp), op0);
1009 default:
1010 return exp;
1013 gcc_unreachable ();
1016 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1017 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1018 to where we should place the result type. */
1020 static tree
1021 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
1023 Node_Id gnat_temp, gnat_temp_type;
1024 tree gnu_result, gnu_result_type;
1026 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1027 specific circumstances only, so evaluated lazily. < 0 means
1028 unknown, > 0 means known true, 0 means known false. */
1029 int require_lvalue = -1;
1031 /* If GNAT_NODE is a constant, whether we should use the initialization
1032 value instead of the constant entity, typically for scalars with an
1033 address clause when the parent doesn't require an lvalue. */
1034 bool use_constant_initializer = false;
1036 /* If the Etype of this node is not the same as that of the Entity, then
1037 something went wrong, probably in generic instantiation. However, this
1038 does not apply to types. Since we sometime have strange Ekind's, just
1039 do this test for objects. Moreover, if the Etype of the Entity is private
1040 or incomplete coming from a limited context, the Etype of the N_Identifier
1041 is allowed to be the full/non-limited view and we also consider a packed
1042 array type to be the same as the original type. Similarly, a CW type is
1043 equivalent to a subtype of itself. Finally, if the types are Itypes, one
1044 may be a copy of the other, which is also legal. */
1045 gnat_temp = ((Nkind (gnat_node) == N_Defining_Identifier
1046 || Nkind (gnat_node) == N_Defining_Operator_Symbol)
1047 ? gnat_node : Entity (gnat_node));
1048 gnat_temp_type = Etype (gnat_temp);
1050 gcc_assert (Etype (gnat_node) == gnat_temp_type
1051 || (Is_Packed (gnat_temp_type)
1052 && (Etype (gnat_node)
1053 == Packed_Array_Impl_Type (gnat_temp_type)))
1054 || (Is_Class_Wide_Type (Etype (gnat_node)))
1055 || (IN (Ekind (gnat_temp_type), Incomplete_Or_Private_Kind)
1056 && Present (Full_View (gnat_temp_type))
1057 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
1058 || (Is_Packed (Full_View (gnat_temp_type))
1059 && (Etype (gnat_node)
1060 == Packed_Array_Impl_Type
1061 (Full_View (gnat_temp_type))))))
1062 || (IN (Ekind (gnat_temp_type), Incomplete_Kind)
1063 && From_Limited_With (gnat_temp_type)
1064 && Present (Non_Limited_View (gnat_temp_type))
1065 && Etype (gnat_node) == Non_Limited_View (gnat_temp_type))
1066 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
1067 || !(Ekind (gnat_temp) == E_Variable
1068 || Ekind (gnat_temp) == E_Component
1069 || Ekind (gnat_temp) == E_Constant
1070 || Ekind (gnat_temp) == E_Loop_Parameter
1071 || IN (Ekind (gnat_temp), Formal_Kind)));
1073 /* If this is a reference to a deferred constant whose partial view is an
1074 unconstrained private type, the proper type is on the full view of the
1075 constant, not on the full view of the type, which may be unconstrained.
1077 This may be a reference to a type, for example in the prefix of the
1078 attribute Position, generated for dispatching code (see Make_DT in
1079 exp_disp,adb). In that case we need the type itself, not is parent,
1080 in particular if it is a derived type */
1081 if (Ekind (gnat_temp) == E_Constant
1082 && Is_Private_Type (gnat_temp_type)
1083 && (Has_Unknown_Discriminants (gnat_temp_type)
1084 || (Present (Full_View (gnat_temp_type))
1085 && Has_Discriminants (Full_View (gnat_temp_type))))
1086 && Present (Full_View (gnat_temp)))
1088 gnat_temp = Full_View (gnat_temp);
1089 gnat_temp_type = Etype (gnat_temp);
1091 else
1093 /* We want to use the Actual_Subtype if it has already been elaborated,
1094 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
1095 simplify things. */
1096 if ((Ekind (gnat_temp) == E_Constant
1097 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
1098 && !(Is_Array_Type (Etype (gnat_temp))
1099 && Present (Packed_Array_Impl_Type (Etype (gnat_temp))))
1100 && Present (Actual_Subtype (gnat_temp))
1101 && present_gnu_tree (Actual_Subtype (gnat_temp)))
1102 gnat_temp_type = Actual_Subtype (gnat_temp);
1103 else
1104 gnat_temp_type = Etype (gnat_node);
1107 /* Expand the type of this identifier first, in case it is an enumeral
1108 literal, which only get made when the type is expanded. There is no
1109 order-of-elaboration issue here. */
1110 gnu_result_type = get_unpadded_type (gnat_temp_type);
1112 /* If this is a non-imported elementary constant with an address clause,
1113 retrieve the value instead of a pointer to be dereferenced unless
1114 an lvalue is required. This is generally more efficient and actually
1115 required if this is a static expression because it might be used
1116 in a context where a dereference is inappropriate, such as a case
1117 statement alternative or a record discriminant. There is no possible
1118 volatile-ness short-circuit here since Volatile constants must be
1119 imported per C.6. */
1120 if (Ekind (gnat_temp) == E_Constant
1121 && Is_Elementary_Type (gnat_temp_type)
1122 && !Is_Imported (gnat_temp)
1123 && Present (Address_Clause (gnat_temp)))
1125 require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
1126 false, Is_Aliased (gnat_temp));
1127 use_constant_initializer = !require_lvalue;
1130 if (use_constant_initializer)
1132 /* If this is a deferred constant, the initializer is attached to
1133 the full view. */
1134 if (Present (Full_View (gnat_temp)))
1135 gnat_temp = Full_View (gnat_temp);
1137 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
1139 else
1140 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, false);
1142 /* Some objects (such as parameters passed by reference, globals of
1143 variable size, and renamed objects) actually represent the address
1144 of the object. In that case, we must do the dereference. Likewise,
1145 deal with parameters to foreign convention subprograms. */
1146 if (DECL_P (gnu_result)
1147 && (DECL_BY_REF_P (gnu_result)
1148 || (TREE_CODE (gnu_result) == PARM_DECL
1149 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
1151 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1153 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1154 if (TREE_CODE (gnu_result) == PARM_DECL
1155 && DECL_BY_COMPONENT_PTR_P (gnu_result))
1156 gnu_result
1157 = convert (build_pointer_type (gnu_result_type), gnu_result);
1159 /* If it's a CONST_DECL, return the underlying constant like below. */
1160 else if (TREE_CODE (gnu_result) == CONST_DECL
1161 && !(DECL_CONST_ADDRESS_P (gnu_result)
1162 && lvalue_required_p (gnat_node, gnu_result_type, true,
1163 true, false)))
1164 gnu_result = DECL_INITIAL (gnu_result);
1166 /* If it's a renaming pointer, get to the renamed object. */
1167 if (TREE_CODE (gnu_result) == VAR_DECL
1168 && !DECL_LOOP_PARM_P (gnu_result)
1169 && DECL_RENAMED_OBJECT (gnu_result))
1170 gnu_result = DECL_RENAMED_OBJECT (gnu_result);
1172 /* Otherwise, do the final dereference. */
1173 else
1175 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1177 if ((TREE_CODE (gnu_result) == INDIRECT_REF
1178 || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
1179 && No (Address_Clause (gnat_temp)))
1180 TREE_THIS_NOTRAP (gnu_result) = 1;
1182 if (read_only)
1183 TREE_READONLY (gnu_result) = 1;
1187 /* If we have a constant declaration and its initializer, try to return the
1188 latter to avoid the need to call fold in lots of places and the need for
1189 elaboration code if this identifier is used as an initializer itself. */
1190 if (constant_decl_with_initializer_p (gnu_result))
1192 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1193 && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1194 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1195 && DECL_CONST_ADDRESS_P (gnu_result));
1197 /* If there is a (corresponding) variable or this is the address of a
1198 constant, we only want to return the initializer if an lvalue isn't
1199 required. Evaluate this now if we have not already done so. */
1200 if ((!constant_only || address_of_constant) && require_lvalue < 0)
1201 require_lvalue
1202 = lvalue_required_p (gnat_node, gnu_result_type, true,
1203 address_of_constant, Is_Aliased (gnat_temp));
1205 /* Finally retrieve the initializer if this is deemed valid. */
1206 if ((constant_only && !address_of_constant) || !require_lvalue)
1207 gnu_result = DECL_INITIAL (gnu_result);
1210 /* But for a constant renaming we couldn't do that incrementally for its
1211 definition because of the need to return an lvalue so, if the present
1212 context doesn't itself require an lvalue, we try again here. */
1213 else if (Ekind (gnat_temp) == E_Constant
1214 && Is_Elementary_Type (gnat_temp_type)
1215 && Present (Renamed_Object (gnat_temp)))
1217 if (require_lvalue < 0)
1218 require_lvalue
1219 = lvalue_required_p (gnat_node, gnu_result_type, true, false,
1220 Is_Aliased (gnat_temp));
1221 if (!require_lvalue)
1222 gnu_result = fold_constant_decl_in_expr (gnu_result);
1225 /* The GNAT tree has the type of a function set to its result type, so we
1226 adjust here. Also use the type of the result if the Etype is a subtype
1227 that is nominally unconstrained. Likewise if this is a deferred constant
1228 of a discriminated type whose full view can be elaborated statically, to
1229 avoid problematic conversions to the nominal subtype. But remove any
1230 padding from the resulting type. */
1231 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1232 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)
1233 || (Ekind (gnat_temp) == E_Constant
1234 && Present (Full_View (gnat_temp))
1235 && Has_Discriminants (gnat_temp_type)
1236 && TREE_CODE (gnu_result) == CONSTRUCTOR))
1238 gnu_result_type = TREE_TYPE (gnu_result);
1239 if (TYPE_IS_PADDING_P (gnu_result_type))
1240 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1243 *gnu_result_type_p = gnu_result_type;
1245 return gnu_result;
1248 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1249 any statements we generate. */
1251 static tree
1252 Pragma_to_gnu (Node_Id gnat_node)
1254 tree gnu_result = alloc_stmt_list ();
1255 unsigned char pragma_id;
1256 Node_Id gnat_temp;
1258 /* Do nothing if we are just annotating types and check for (and ignore)
1259 unrecognized pragmas. */
1260 if (type_annotate_only
1261 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1262 return gnu_result;
1264 pragma_id = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
1265 switch (pragma_id)
1267 case Pragma_Inspection_Point:
1268 /* Do nothing at top level: all such variables are already viewable. */
1269 if (global_bindings_p ())
1270 break;
1272 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1273 Present (gnat_temp);
1274 gnat_temp = Next (gnat_temp))
1276 Node_Id gnat_expr = Expression (gnat_temp);
1277 tree gnu_expr = gnat_to_gnu (gnat_expr);
1278 int use_address;
1279 machine_mode mode;
1280 scalar_int_mode int_mode;
1281 tree asm_constraint = NULL_TREE;
1282 #ifdef ASM_COMMENT_START
1283 char *comment;
1284 #endif
1286 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1287 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1289 /* Use the value only if it fits into a normal register,
1290 otherwise use the address. */
1291 mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1292 use_address = (!is_a <scalar_int_mode> (mode, &int_mode)
1293 || GET_MODE_SIZE (int_mode) > UNITS_PER_WORD);
1295 if (use_address)
1296 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1298 #ifdef ASM_COMMENT_START
1299 comment = concat (ASM_COMMENT_START,
1300 " inspection point: ",
1301 Get_Name_String (Chars (gnat_expr)),
1302 use_address ? " address" : "",
1303 " is in %0",
1304 NULL);
1305 asm_constraint = build_string (strlen (comment), comment);
1306 free (comment);
1307 #endif
1308 gnu_expr = build5 (ASM_EXPR, void_type_node,
1309 asm_constraint,
1310 NULL_TREE,
1311 tree_cons
1312 (build_tree_list (NULL_TREE,
1313 build_string (1, "g")),
1314 gnu_expr, NULL_TREE),
1315 NULL_TREE, NULL_TREE);
1316 ASM_VOLATILE_P (gnu_expr) = 1;
1317 set_expr_location_from_node (gnu_expr, gnat_node);
1318 append_to_statement_list (gnu_expr, &gnu_result);
1320 break;
1322 case Pragma_Loop_Optimize:
1323 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1324 Present (gnat_temp);
1325 gnat_temp = Next (gnat_temp))
1327 tree gnu_loop_stmt = gnu_loop_stack->last ()->stmt;
1329 switch (Chars (Expression (gnat_temp)))
1331 case Name_Ivdep:
1332 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
1333 break;
1335 case Name_No_Unroll:
1336 LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1;
1337 break;
1339 case Name_Unroll:
1340 LOOP_STMT_UNROLL (gnu_loop_stmt) = 1;
1341 break;
1343 case Name_No_Vector:
1344 LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1;
1345 break;
1347 case Name_Vector:
1348 LOOP_STMT_VECTOR (gnu_loop_stmt) = 1;
1349 break;
1351 default:
1352 gcc_unreachable ();
1355 break;
1357 case Pragma_Optimize:
1358 switch (Chars (Expression
1359 (First (Pragma_Argument_Associations (gnat_node)))))
1361 case Name_Off:
1362 if (optimize)
1363 post_error ("must specify -O0?", gnat_node);
1364 break;
1366 case Name_Space:
1367 if (!optimize_size)
1368 post_error ("must specify -Os?", gnat_node);
1369 break;
1371 case Name_Time:
1372 if (!optimize)
1373 post_error ("insufficient -O value?", gnat_node);
1374 break;
1376 default:
1377 gcc_unreachable ();
1379 break;
1381 case Pragma_Reviewable:
1382 if (write_symbols == NO_DEBUG)
1383 post_error ("must specify -g?", gnat_node);
1384 break;
1386 case Pragma_Warning_As_Error:
1387 case Pragma_Warnings:
1389 Node_Id gnat_expr;
1390 /* Preserve the location of the pragma. */
1391 const location_t location = input_location;
1392 struct cl_option_handlers handlers;
1393 unsigned int option_index;
1394 diagnostic_t kind;
1395 bool imply;
1397 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1399 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1400 if (Nkind (Expression (gnat_temp)) == N_String_Literal)
1402 switch (pragma_id)
1404 case Pragma_Warning_As_Error:
1405 kind = DK_ERROR;
1406 imply = false;
1407 break;
1409 case Pragma_Warnings:
1410 kind = DK_WARNING;
1411 imply = true;
1412 break;
1414 default:
1415 gcc_unreachable ();
1418 gnat_expr = Expression (gnat_temp);
1421 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1422 else if (Nkind (Expression (gnat_temp)) == N_Identifier)
1424 switch (Chars (Expression (gnat_temp)))
1426 case Name_Off:
1427 kind = DK_IGNORED;
1428 break;
1430 case Name_On:
1431 kind = DK_WARNING;
1432 break;
1434 default:
1435 gcc_unreachable ();
1438 /* Deal with optional pattern (but ignore Reason => "..."). */
1439 if (Present (Next (gnat_temp))
1440 && Chars (Next (gnat_temp)) != Name_Reason)
1442 /* pragma Warnings (On | Off, Name) is handled differently. */
1443 if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal)
1444 break;
1446 gnat_expr = Expression (Next (gnat_temp));
1448 else
1449 gnat_expr = Empty;
1451 imply = false;
1454 else
1455 gcc_unreachable ();
1457 /* This is the same implementation as in the C family of compilers. */
1458 const unsigned int lang_mask = CL_Ada | CL_COMMON;
1459 const char *arg = NULL;
1460 if (Present (gnat_expr))
1462 tree gnu_expr = gnat_to_gnu (gnat_expr);
1463 const char *option_string = TREE_STRING_POINTER (gnu_expr);
1464 const int len = TREE_STRING_LENGTH (gnu_expr);
1465 if (len < 3 || option_string[0] != '-' || option_string[1] != 'W')
1466 break;
1467 option_index = find_opt (option_string + 1, lang_mask);
1468 if (option_index == OPT_SPECIAL_unknown)
1470 post_error ("?unknown -W switch", gnat_node);
1471 break;
1473 else if (!(cl_options[option_index].flags & CL_WARNING))
1475 post_error ("?-W switch does not control warning", gnat_node);
1476 break;
1478 else if (!(cl_options[option_index].flags & lang_mask))
1480 post_error ("?-W switch not valid for Ada", gnat_node);
1481 break;
1483 if (cl_options[option_index].flags & CL_JOINED)
1484 arg = option_string + 1 + cl_options[option_index].opt_len;
1486 else
1487 option_index = 0;
1489 set_default_handlers (&handlers, NULL);
1490 control_warning_option (option_index, (int) kind, arg, imply, location,
1491 lang_mask, &handlers, &global_options,
1492 &global_options_set, global_dc);
1494 break;
1496 default:
1497 break;
1500 return gnu_result;
1504 /* Check the inline status of nested function FNDECL wrt its parent function.
1506 If a non-inline nested function is referenced from an inline external
1507 function, we cannot honor both requests at the same time without cloning
1508 the nested function in the current unit since it is private to its unit.
1509 We could inline it as well but it's probably better to err on the side
1510 of too little inlining.
1512 This must be done only on nested functions present in the source code
1513 and not on nested functions generated by the compiler, e.g. finalizers,
1514 because they may be not marked inline and we don't want them to block
1515 the inlining of the parent function. */
1517 static void
1518 check_inlining_for_nested_subprog (tree fndecl)
1520 if (DECL_IGNORED_P (current_function_decl) || DECL_IGNORED_P (fndecl))
1521 return;
1523 if (DECL_DECLARED_INLINE_P (fndecl))
1524 return;
1526 tree parent_decl = decl_function_context (fndecl);
1527 if (DECL_EXTERNAL (parent_decl) && DECL_DECLARED_INLINE_P (parent_decl))
1529 const location_t loc1 = DECL_SOURCE_LOCATION (fndecl);
1530 const location_t loc2 = DECL_SOURCE_LOCATION (parent_decl);
1532 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl)))
1534 error_at (loc1, "subprogram %q+F not marked Inline_Always", fndecl);
1535 error_at (loc2, "parent subprogram cannot be inlined");
1537 else
1539 warning_at (loc1, OPT_Winline, "subprogram %q+F not marked Inline",
1540 fndecl);
1541 warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined");
1544 DECL_DECLARED_INLINE_P (parent_decl) = 0;
1545 DECL_UNINLINABLE (parent_decl) = 1;
1549 /* Return an expression for the length of TYPE, an integral type, computed in
1550 RESULT_TYPE, another integral type.
1552 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1553 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1554 which would only overflow in much rarer cases, for extremely large arrays
1555 we expect never to encounter in practice. Besides, the former computation
1556 required the use of potentially constraining signed arithmetics while the
1557 latter does not. Note that the comparison must be done in the original
1558 base index type in order to avoid any overflow during the conversion. */
1560 static tree
1561 get_type_length (tree type, tree result_type)
1563 tree comp_type = get_base_type (result_type);
1564 tree base_type = maybe_character_type (get_base_type (type));
1565 tree lb = convert (base_type, TYPE_MIN_VALUE (type));
1566 tree hb = convert (base_type, TYPE_MAX_VALUE (type));
1567 tree length
1568 = build_binary_op (PLUS_EXPR, comp_type,
1569 build_binary_op (MINUS_EXPR, comp_type,
1570 convert (comp_type, hb),
1571 convert (comp_type, lb)),
1572 build_int_cst (comp_type, 1));
1573 length
1574 = build_cond_expr (result_type,
1575 build_binary_op (GE_EXPR, boolean_type_node, hb, lb),
1576 convert (result_type, length),
1577 build_int_cst (result_type, 0));
1578 return length;
1581 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1582 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1583 where we should place the result type. ATTRIBUTE is the attribute ID. */
1585 static tree
1586 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1588 const Node_Id gnat_prefix = Prefix (gnat_node);
1589 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
1590 tree gnu_type = TREE_TYPE (gnu_prefix);
1591 tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1592 bool prefix_unused = false;
1594 /* If the input is a NULL_EXPR, make a new one. */
1595 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1597 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1598 *gnu_result_type_p = gnu_result_type;
1599 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1602 switch (attribute)
1604 case Attr_Pos:
1605 case Attr_Val:
1606 /* These are just conversions since representation clauses for
1607 enumeration types are handled in the front-end. */
1608 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1609 if (attribute == Attr_Pos)
1610 gnu_expr = maybe_character_value (gnu_expr);
1611 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1612 gnu_result = convert (gnu_result_type, gnu_expr);
1613 break;
1615 case Attr_Pred:
1616 case Attr_Succ:
1617 /* These just add or subtract the constant 1 since representation
1618 clauses for enumeration types are handled in the front-end. */
1619 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1620 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1621 gnu_type = maybe_character_type (gnu_result_type);
1622 if (TREE_TYPE (gnu_expr) != gnu_type)
1623 gnu_expr = convert (gnu_type, gnu_expr);
1624 gnu_result
1625 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1626 gnu_type, gnu_expr, build_int_cst (gnu_type, 1));
1627 break;
1629 case Attr_Address:
1630 case Attr_Unrestricted_Access:
1631 /* Conversions don't change addresses but can cause us to miss the
1632 COMPONENT_REF case below, so strip them off. */
1633 gnu_prefix = remove_conversions (gnu_prefix,
1634 !Must_Be_Byte_Aligned (gnat_node));
1636 /* If we are taking 'Address of an unconstrained object, this is the
1637 pointer to the underlying array. */
1638 if (attribute == Attr_Address)
1639 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1641 /* If we are building a static dispatch table, we have to honor
1642 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1643 with the C++ ABI. We do it in the non-static case as well,
1644 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1645 else if (TARGET_VTABLE_USES_DESCRIPTORS
1646 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1648 tree gnu_field, t;
1649 /* Descriptors can only be built here for top-level functions. */
1650 bool build_descriptor = (global_bindings_p () != 0);
1651 int i;
1652 vec<constructor_elt, va_gc> *gnu_vec = NULL;
1653 constructor_elt *elt;
1655 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1657 /* If we're not going to build the descriptor, we have to retrieve
1658 the one which will be built by the linker (or by the compiler
1659 later if a static chain is requested). */
1660 if (!build_descriptor)
1662 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1663 gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1664 gnu_result);
1665 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1668 vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS);
1669 elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1670 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1671 i < TARGET_VTABLE_USES_DESCRIPTORS;
1672 gnu_field = DECL_CHAIN (gnu_field), i++)
1674 if (build_descriptor)
1676 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1677 build_int_cst (NULL_TREE, i));
1678 TREE_CONSTANT (t) = 1;
1680 else
1681 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1682 gnu_field, NULL_TREE);
1684 elt->index = gnu_field;
1685 elt->value = t;
1686 elt--;
1689 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1690 break;
1693 /* ... fall through ... */
1695 case Attr_Access:
1696 case Attr_Unchecked_Access:
1697 case Attr_Code_Address:
1698 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1699 gnu_result
1700 = build_unary_op (((attribute == Attr_Address
1701 || attribute == Attr_Unrestricted_Access)
1702 && !Must_Be_Byte_Aligned (gnat_node))
1703 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1704 gnu_result_type, gnu_prefix);
1706 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1707 don't try to build a trampoline. */
1708 if (attribute == Attr_Code_Address)
1710 gnu_expr = remove_conversions (gnu_result, false);
1712 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1713 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1715 /* On targets for which function symbols denote a descriptor, the
1716 code address is stored within the first slot of the descriptor
1717 so we do an additional dereference:
1718 result = *((result_type *) result)
1719 where we expect result to be of some pointer type already. */
1720 if (targetm.calls.custom_function_descriptors == 0)
1721 gnu_result
1722 = build_unary_op (INDIRECT_REF, NULL_TREE,
1723 convert (build_pointer_type (gnu_result_type),
1724 gnu_result));
1727 /* For 'Access, issue an error message if the prefix is a C++ method
1728 since it can use a special calling convention on some platforms,
1729 which cannot be propagated to the access type. */
1730 else if (attribute == Attr_Access
1731 && Nkind (gnat_prefix) == N_Identifier
1732 && is_cplusplus_method (Entity (gnat_prefix)))
1733 post_error ("access to C++ constructor or member function not allowed",
1734 gnat_node);
1736 /* For other address attributes applied to a nested function,
1737 find an inner ADDR_EXPR and annotate it so that we can issue
1738 a useful warning with -Wtrampolines. */
1739 else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1741 gnu_expr = remove_conversions (gnu_result, false);
1743 if (TREE_CODE (gnu_expr) == ADDR_EXPR
1744 && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1746 set_expr_location_from_node (gnu_expr, gnat_node);
1748 /* Also check the inlining status. */
1749 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
1751 /* Moreover, for 'Access or 'Unrestricted_Access with non-
1752 foreign-compatible representation, mark the ADDR_EXPR so
1753 that we can build a descriptor instead of a trampoline. */
1754 if ((attribute == Attr_Access
1755 || attribute == Attr_Unrestricted_Access)
1756 && targetm.calls.custom_function_descriptors > 0
1757 && Can_Use_Internal_Rep (Etype (gnat_node)))
1758 FUNC_ADDR_BY_DESCRIPTOR (gnu_expr) = 1;
1760 /* Otherwise, we need to check that we are not violating the
1761 No_Implicit_Dynamic_Code restriction. */
1762 else if (targetm.calls.custom_function_descriptors != 0)
1763 Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1766 break;
1768 case Attr_Pool_Address:
1770 tree gnu_ptr = gnu_prefix;
1771 tree gnu_obj_type;
1773 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1775 /* If this is fat pointer, the object must have been allocated with the
1776 template in front of the array. So compute the template address; do
1777 it by converting to a thin pointer. */
1778 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1779 gnu_ptr
1780 = convert (build_pointer_type
1781 (TYPE_OBJECT_RECORD_TYPE
1782 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1783 gnu_ptr);
1785 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1787 /* If this is a thin pointer, the object must have been allocated with
1788 the template in front of the array. So compute the template address
1789 and return it. */
1790 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
1791 gnu_ptr
1792 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
1793 gnu_ptr,
1794 fold_build1 (NEGATE_EXPR, sizetype,
1795 byte_position
1796 (DECL_CHAIN
1797 TYPE_FIELDS ((gnu_obj_type)))));
1799 gnu_result = convert (gnu_result_type, gnu_ptr);
1801 break;
1803 case Attr_Size:
1804 case Attr_Object_Size:
1805 case Attr_Value_Size:
1806 case Attr_Max_Size_In_Storage_Elements:
1807 gnu_expr = gnu_prefix;
1809 /* Remove NOPs and conversions between original and packable version
1810 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
1811 to see if a COMPONENT_REF was involved. */
1812 while (TREE_CODE (gnu_expr) == NOP_EXPR
1813 || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1814 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1815 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1816 == RECORD_TYPE
1817 && TYPE_NAME (TREE_TYPE (gnu_expr))
1818 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1819 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1821 gnu_prefix = remove_conversions (gnu_prefix, true);
1822 prefix_unused = true;
1823 gnu_type = TREE_TYPE (gnu_prefix);
1825 /* Replace an unconstrained array type with the type of the underlying
1826 array. We can't do this with a call to maybe_unconstrained_array
1827 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
1828 use the record type that will be used to allocate the object and its
1829 template. */
1830 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1832 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1833 if (attribute != Attr_Max_Size_In_Storage_Elements)
1834 gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1837 /* If we're looking for the size of a field, return the field size. */
1838 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1839 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1841 /* Otherwise, if the prefix is an object, or if we are looking for
1842 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1843 GCC size of the type. We make an exception for padded objects,
1844 as we do not take into account alignment promotions for the size.
1845 This is in keeping with the object case of gnat_to_gnu_entity. */
1846 else if ((TREE_CODE (gnu_prefix) != TYPE_DECL
1847 && !(TYPE_IS_PADDING_P (gnu_type)
1848 && TREE_CODE (gnu_expr) == COMPONENT_REF))
1849 || attribute == Attr_Object_Size
1850 || attribute == Attr_Max_Size_In_Storage_Elements)
1852 /* If this is a dereference and we have a special dynamic constrained
1853 subtype on the prefix, use it to compute the size; otherwise, use
1854 the designated subtype. */
1855 if (Nkind (gnat_prefix) == N_Explicit_Dereference)
1857 Node_Id gnat_actual_subtype
1858 = Actual_Designated_Subtype (gnat_prefix);
1859 tree gnu_ptr_type
1860 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
1862 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1863 && Present (gnat_actual_subtype))
1865 tree gnu_actual_obj_type
1866 = gnat_to_gnu_type (gnat_actual_subtype);
1867 gnu_type
1868 = build_unc_object_type_from_ptr (gnu_ptr_type,
1869 gnu_actual_obj_type,
1870 get_identifier ("SIZE"),
1871 false);
1875 gnu_result = TYPE_SIZE (gnu_type);
1878 /* Otherwise, the result is the RM size of the type. */
1879 else
1880 gnu_result = rm_size (gnu_type);
1882 /* Deal with a self-referential size by returning the maximum size for
1883 a type and by qualifying the size with the object otherwise. */
1884 if (CONTAINS_PLACEHOLDER_P (gnu_result))
1886 if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1887 gnu_result = max_size (gnu_result, true);
1888 else
1889 gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1892 /* If the type contains a template, subtract its size. */
1893 if (TREE_CODE (gnu_type) == RECORD_TYPE
1894 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1895 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1896 DECL_SIZE (TYPE_FIELDS (gnu_type)));
1898 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
1899 if (attribute == Attr_Max_Size_In_Storage_Elements)
1900 gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1902 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1903 break;
1905 case Attr_Alignment:
1907 unsigned int align;
1909 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1910 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1911 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1913 gnu_type = TREE_TYPE (gnu_prefix);
1914 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1915 prefix_unused = true;
1917 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1918 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1919 else
1921 Entity_Id gnat_type = Etype (gnat_prefix);
1922 unsigned int double_align;
1923 bool is_capped_double, align_clause;
1925 /* If the default alignment of "double" or larger scalar types is
1926 specifically capped and there is an alignment clause neither
1927 on the type nor on the prefix itself, return the cap. */
1928 if ((double_align = double_float_alignment) > 0)
1929 is_capped_double
1930 = is_double_float_or_array (gnat_type, &align_clause);
1931 else if ((double_align = double_scalar_alignment) > 0)
1932 is_capped_double
1933 = is_double_scalar_or_array (gnat_type, &align_clause);
1934 else
1935 is_capped_double = align_clause = false;
1937 if (is_capped_double
1938 && Nkind (gnat_prefix) == N_Identifier
1939 && Present (Alignment_Clause (Entity (gnat_prefix))))
1940 align_clause = true;
1942 if (is_capped_double && !align_clause)
1943 align = double_align;
1944 else
1945 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1948 gnu_result = size_int (align);
1950 break;
1952 case Attr_First:
1953 case Attr_Last:
1954 case Attr_Range_Length:
1955 prefix_unused = true;
1957 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1959 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1961 if (attribute == Attr_First)
1962 gnu_result = TYPE_MIN_VALUE (gnu_type);
1963 else if (attribute == Attr_Last)
1964 gnu_result = TYPE_MAX_VALUE (gnu_type);
1965 else
1966 gnu_result = get_type_length (gnu_type, gnu_result_type);
1967 break;
1970 /* ... fall through ... */
1972 case Attr_Length:
1974 int Dimension = (Present (Expressions (gnat_node))
1975 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1976 : 1), i;
1977 struct parm_attr_d *pa = NULL;
1978 Entity_Id gnat_param = Empty;
1979 bool unconstrained_ptr_deref = false;
1981 /* Make sure any implicit dereference gets done. */
1982 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1983 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1985 /* We treat unconstrained array In parameters specially. We also note
1986 whether we are dereferencing a pointer to unconstrained array. */
1987 if (!Is_Constrained (Etype (gnat_prefix)))
1988 switch (Nkind (gnat_prefix))
1990 case N_Identifier:
1991 /* This is the direct case. */
1992 if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
1993 gnat_param = Entity (gnat_prefix);
1994 break;
1996 case N_Explicit_Dereference:
1997 /* This is the indirect case. Note that we need to be sure that
1998 the access value cannot be null as we'll hoist the load. */
1999 if (Nkind (Prefix (gnat_prefix)) == N_Identifier
2000 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
2002 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
2003 gnat_param = Entity (Prefix (gnat_prefix));
2005 else
2006 unconstrained_ptr_deref = true;
2007 break;
2009 default:
2010 break;
2013 /* If the prefix is the view conversion of a constrained array to an
2014 unconstrained form, we retrieve the constrained array because we
2015 might not be able to substitute the PLACEHOLDER_EXPR coming from
2016 the conversion. This can occur with the 'Old attribute applied
2017 to a parameter with an unconstrained type, which gets rewritten
2018 into a constrained local variable very late in the game. */
2019 if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
2020 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix)))
2021 && !CONTAINS_PLACEHOLDER_P
2022 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
2023 gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0));
2024 else
2025 gnu_type = TREE_TYPE (gnu_prefix);
2027 prefix_unused = true;
2028 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2030 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
2032 int ndim;
2033 tree gnu_type_temp;
2035 for (ndim = 1, gnu_type_temp = gnu_type;
2036 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
2037 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
2038 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
2041 Dimension = ndim + 1 - Dimension;
2044 for (i = 1; i < Dimension; i++)
2045 gnu_type = TREE_TYPE (gnu_type);
2047 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2049 /* When not optimizing, look up the slot associated with the parameter
2050 and the dimension in the cache and create a new one on failure.
2051 Don't do this when the actual subtype needs debug info (this happens
2052 with -gnatD): in elaborate_expression_1, we create variables that
2053 hold the bounds, so caching attributes isn't very interesting and
2054 causes dependency issues between these variables and cached
2055 expressions. */
2056 if (!optimize
2057 && Present (gnat_param)
2058 && !(Present (Actual_Subtype (gnat_param))
2059 && Needs_Debug_Info (Actual_Subtype (gnat_param))))
2061 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa)
2062 if (pa->id == gnat_param && pa->dim == Dimension)
2063 break;
2065 if (!pa)
2067 pa = ggc_cleared_alloc<parm_attr_d> ();
2068 pa->id = gnat_param;
2069 pa->dim = Dimension;
2070 vec_safe_push (f_parm_attr_cache, pa);
2074 /* Return the cached expression or build a new one. */
2075 if (attribute == Attr_First)
2077 if (pa && pa->first)
2079 gnu_result = pa->first;
2080 break;
2083 gnu_result
2084 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2087 else if (attribute == Attr_Last)
2089 if (pa && pa->last)
2091 gnu_result = pa->last;
2092 break;
2095 gnu_result
2096 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2099 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2101 if (pa && pa->length)
2103 gnu_result = pa->length;
2104 break;
2107 gnu_result
2108 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)),
2109 gnu_result_type);
2112 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2113 handling. Note that these attributes could not have been used on
2114 an unconstrained array type. */
2115 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2117 /* Cache the expression we have just computed. Since we want to do it
2118 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2119 create the temporary in the outermost binding level. We will make
2120 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2121 paths by forcing its evaluation on entry of the function. */
2122 if (pa)
2124 gnu_result
2125 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2126 switch (attribute)
2128 case Attr_First:
2129 pa->first = gnu_result;
2130 break;
2132 case Attr_Last:
2133 pa->last = gnu_result;
2134 break;
2136 case Attr_Length:
2137 case Attr_Range_Length:
2138 pa->length = gnu_result;
2139 break;
2141 default:
2142 gcc_unreachable ();
2146 /* Otherwise, evaluate it each time it is referenced. */
2147 else
2148 switch (attribute)
2150 case Attr_First:
2151 case Attr_Last:
2152 /* If we are dereferencing a pointer to unconstrained array, we
2153 need to capture the value because the pointed-to bounds may
2154 subsequently be released. */
2155 if (unconstrained_ptr_deref)
2156 gnu_result
2157 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2158 break;
2160 case Attr_Length:
2161 case Attr_Range_Length:
2162 /* Set the source location onto the predicate of the condition
2163 but not if the expression is cached to avoid messing up the
2164 debug info. */
2165 if (TREE_CODE (gnu_result) == COND_EXPR
2166 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
2167 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
2168 gnat_node);
2169 break;
2171 default:
2172 gcc_unreachable ();
2175 break;
2178 case Attr_Bit_Position:
2179 case Attr_Position:
2180 case Attr_First_Bit:
2181 case Attr_Last_Bit:
2182 case Attr_Bit:
2184 HOST_WIDE_INT bitsize;
2185 HOST_WIDE_INT bitpos;
2186 tree gnu_offset;
2187 tree gnu_field_bitpos;
2188 tree gnu_field_offset;
2189 tree gnu_inner;
2190 machine_mode mode;
2191 int unsignedp, reversep, volatilep;
2193 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2194 gnu_prefix = remove_conversions (gnu_prefix, true);
2195 prefix_unused = true;
2197 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2198 the result is 0. Don't allow 'Bit on a bare component, though. */
2199 if (attribute == Attr_Bit
2200 && TREE_CODE (gnu_prefix) != COMPONENT_REF
2201 && TREE_CODE (gnu_prefix) != FIELD_DECL)
2203 gnu_result = integer_zero_node;
2204 break;
2207 else
2208 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
2209 || (attribute == Attr_Bit_Position
2210 && TREE_CODE (gnu_prefix) == FIELD_DECL));
2212 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
2213 &mode, &unsignedp, &reversep, &volatilep);
2215 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2217 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
2218 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
2220 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
2221 TREE_CODE (gnu_inner) == COMPONENT_REF
2222 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
2223 gnu_inner = TREE_OPERAND (gnu_inner, 0))
2225 gnu_field_bitpos
2226 = size_binop (PLUS_EXPR, gnu_field_bitpos,
2227 bit_position (TREE_OPERAND (gnu_inner, 1)));
2228 gnu_field_offset
2229 = size_binop (PLUS_EXPR, gnu_field_offset,
2230 byte_position (TREE_OPERAND (gnu_inner, 1)));
2233 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
2235 gnu_field_bitpos = bit_position (gnu_prefix);
2236 gnu_field_offset = byte_position (gnu_prefix);
2238 else
2240 gnu_field_bitpos = bitsize_zero_node;
2241 gnu_field_offset = size_zero_node;
2244 switch (attribute)
2246 case Attr_Position:
2247 gnu_result = gnu_field_offset;
2248 break;
2250 case Attr_First_Bit:
2251 case Attr_Bit:
2252 gnu_result = size_int (bitpos % BITS_PER_UNIT);
2253 break;
2255 case Attr_Last_Bit:
2256 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
2257 gnu_result = size_binop (PLUS_EXPR, gnu_result,
2258 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
2259 /* ??? Avoid a large unsigned result that will overflow when
2260 converted to the signed universal_integer. */
2261 if (integer_zerop (gnu_result))
2262 gnu_result = integer_minus_one_node;
2263 else
2264 gnu_result
2265 = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node);
2266 break;
2268 case Attr_Bit_Position:
2269 gnu_result = gnu_field_bitpos;
2270 break;
2273 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2274 handling. */
2275 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2276 break;
2279 case Attr_Min:
2280 case Attr_Max:
2282 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
2283 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
2285 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2287 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2288 a NaN so we implement the semantics of C99 f{min,max} to make it
2289 predictable in this case: if either operand is a NaN, the other
2290 is returned; if both operands are NaN's, a NaN is returned. */
2291 if (SCALAR_FLOAT_TYPE_P (gnu_result_type)
2292 && !Machine_Overflows_On_Target)
2294 const bool lhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_lhs);
2295 const bool rhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_rhs);
2296 tree t = builtin_decl_explicit (BUILT_IN_ISNAN);
2297 tree lhs_is_nan, rhs_is_nan;
2299 /* If the operands have side-effects, they need to be evaluated
2300 only once in spite of the multiple references in the result. */
2301 if (lhs_side_effects_p)
2302 gnu_lhs = gnat_protect_expr (gnu_lhs);
2303 if (rhs_side_effects_p)
2304 gnu_rhs = gnat_protect_expr (gnu_rhs);
2306 lhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2307 build_call_expr (t, 1, gnu_lhs),
2308 integer_zero_node);
2310 rhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2311 build_call_expr (t, 1, gnu_rhs),
2312 integer_zero_node);
2314 gnu_result = build_binary_op (attribute == Attr_Min
2315 ? MIN_EXPR : MAX_EXPR,
2316 gnu_result_type, gnu_lhs, gnu_rhs);
2317 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2318 rhs_is_nan, gnu_lhs, gnu_result);
2319 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2320 lhs_is_nan, gnu_rhs, gnu_result);
2322 /* If the operands have side-effects, they need to be evaluated
2323 before doing the tests above since the place they otherwise
2324 would end up being evaluated at run time could be wrong. */
2325 if (lhs_side_effects_p)
2326 gnu_result
2327 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_lhs, gnu_result);
2329 if (rhs_side_effects_p)
2330 gnu_result
2331 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_rhs, gnu_result);
2333 else
2334 gnu_result = build_binary_op (attribute == Attr_Min
2335 ? MIN_EXPR : MAX_EXPR,
2336 gnu_result_type, gnu_lhs, gnu_rhs);
2338 break;
2340 case Attr_Passed_By_Reference:
2341 gnu_result = size_int (default_pass_by_ref (gnu_type)
2342 || must_pass_by_ref (gnu_type));
2343 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2344 break;
2346 case Attr_Component_Size:
2347 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
2348 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
2349 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
2351 gnu_prefix = maybe_implicit_deref (gnu_prefix);
2352 gnu_type = TREE_TYPE (gnu_prefix);
2354 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2355 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
2357 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2358 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
2359 gnu_type = TREE_TYPE (gnu_type);
2361 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2363 /* Note this size cannot be self-referential. */
2364 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
2365 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2366 prefix_unused = true;
2367 break;
2369 case Attr_Descriptor_Size:
2370 gnu_type = TREE_TYPE (gnu_prefix);
2371 gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
2373 /* What we want is the offset of the ARRAY field in the record
2374 that the thin pointer designates. */
2375 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
2376 gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
2377 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2378 prefix_unused = true;
2379 break;
2381 case Attr_Null_Parameter:
2382 /* This is just a zero cast to the pointer type for our prefix and
2383 dereferenced. */
2384 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2385 gnu_result
2386 = build_unary_op (INDIRECT_REF, NULL_TREE,
2387 convert (build_pointer_type (gnu_result_type),
2388 integer_zero_node));
2389 TREE_PRIVATE (gnu_result) = 1;
2390 break;
2392 case Attr_Mechanism_Code:
2394 Entity_Id gnat_obj = Entity (gnat_prefix);
2395 int code;
2397 prefix_unused = true;
2398 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2399 if (Present (Expressions (gnat_node)))
2401 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
2403 for (gnat_obj = First_Formal (gnat_obj); i > 1;
2404 i--, gnat_obj = Next_Formal (gnat_obj))
2408 code = Mechanism (gnat_obj);
2409 if (code == Default)
2410 code = ((present_gnu_tree (gnat_obj)
2411 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
2412 || ((TREE_CODE (get_gnu_tree (gnat_obj))
2413 == PARM_DECL)
2414 && (DECL_BY_COMPONENT_PTR_P
2415 (get_gnu_tree (gnat_obj))))))
2416 ? By_Reference : By_Copy);
2417 gnu_result = convert (gnu_result_type, size_int (- code));
2419 break;
2421 case Attr_Model:
2422 /* We treat Model as identical to Machine. This is true for at least
2423 IEEE and some other nice floating-point systems. */
2425 /* ... fall through ... */
2427 case Attr_Machine:
2428 /* The trick is to force the compiler to store the result in memory so
2429 that we do not have extra precision used. But do this only when this
2430 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2431 the type is lower than that of the longest floating-point type. */
2432 prefix_unused = true;
2433 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2434 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2435 gnu_result = convert (gnu_result_type, gnu_expr);
2437 if (TREE_CODE (gnu_result) != REAL_CST
2438 && fp_arith_may_widen
2439 && TYPE_PRECISION (gnu_result_type)
2440 < TYPE_PRECISION (longest_float_type_node))
2442 tree rec_type = make_node (RECORD_TYPE);
2443 tree field
2444 = create_field_decl (get_identifier ("OBJ"), gnu_result_type,
2445 rec_type, NULL_TREE, NULL_TREE, 0, 0);
2446 tree rec_val, asm_expr;
2448 finish_record_type (rec_type, field, 0, false);
2450 rec_val = build_constructor_single (rec_type, field, gnu_result);
2451 rec_val = build1 (SAVE_EXPR, rec_type, rec_val);
2453 asm_expr
2454 = build5 (ASM_EXPR, void_type_node,
2455 build_string (0, ""),
2456 tree_cons (build_tree_list (NULL_TREE,
2457 build_string (2, "=m")),
2458 rec_val, NULL_TREE),
2459 tree_cons (build_tree_list (NULL_TREE,
2460 build_string (1, "m")),
2461 rec_val, NULL_TREE),
2462 NULL_TREE, NULL_TREE);
2463 ASM_VOLATILE_P (asm_expr) = 1;
2465 gnu_result
2466 = build_compound_expr (gnu_result_type, asm_expr,
2467 build_component_ref (rec_val, field,
2468 false));
2470 break;
2472 case Attr_Deref:
2473 prefix_unused = true;
2474 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2475 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2476 /* This can be a random address so build an alias-all pointer type. */
2477 gnu_expr
2478 = convert (build_pointer_type_for_mode (gnu_result_type, ptr_mode,
2479 true),
2480 gnu_expr);
2481 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_expr);
2482 break;
2484 default:
2485 /* This abort means that we have an unimplemented attribute. */
2486 gcc_unreachable ();
2489 /* If this is an attribute where the prefix was unused, force a use of it if
2490 it has a side-effect. But don't do it if the prefix is just an entity
2491 name. However, if an access check is needed, we must do it. See second
2492 example in AARM 11.6(5.e). */
2493 if (prefix_unused
2494 && TREE_SIDE_EFFECTS (gnu_prefix)
2495 && !Is_Entity_Name (gnat_prefix))
2496 gnu_result
2497 = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
2499 *gnu_result_type_p = gnu_result_type;
2500 return gnu_result;
2503 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2504 to a GCC tree, which is returned. */
2506 static tree
2507 Case_Statement_to_gnu (Node_Id gnat_node)
2509 tree gnu_result, gnu_expr, gnu_type, gnu_label;
2510 Node_Id gnat_when;
2511 location_t end_locus;
2512 bool may_fallthru = false;
2514 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2515 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2516 gnu_expr = maybe_character_value (gnu_expr);
2517 gnu_type = TREE_TYPE (gnu_expr);
2519 /* We build a SWITCH_EXPR that contains the code with interspersed
2520 CASE_LABEL_EXPRs for each label. */
2521 if (!Sloc_to_locus (End_Location (gnat_node), &end_locus))
2522 end_locus = input_location;
2523 gnu_label = create_artificial_label (end_locus);
2524 start_stmt_group ();
2526 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2527 Present (gnat_when);
2528 gnat_when = Next_Non_Pragma (gnat_when))
2530 bool choices_added_p = false;
2531 Node_Id gnat_choice;
2533 /* First compile all the different case choices for the current WHEN
2534 alternative. */
2535 for (gnat_choice = First (Discrete_Choices (gnat_when));
2536 Present (gnat_choice);
2537 gnat_choice = Next (gnat_choice))
2539 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2540 tree label = create_artificial_label (input_location);
2542 switch (Nkind (gnat_choice))
2544 case N_Range:
2545 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2546 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2547 break;
2549 case N_Subtype_Indication:
2550 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2551 (Constraint (gnat_choice))));
2552 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2553 (Constraint (gnat_choice))));
2554 break;
2556 case N_Identifier:
2557 case N_Expanded_Name:
2558 /* This represents either a subtype range or a static value of
2559 some kind; Ekind says which. */
2560 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2562 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2564 gnu_low = TYPE_MIN_VALUE (gnu_type);
2565 gnu_high = TYPE_MAX_VALUE (gnu_type);
2566 break;
2569 /* ... fall through ... */
2571 case N_Character_Literal:
2572 case N_Integer_Literal:
2573 gnu_low = gnat_to_gnu (gnat_choice);
2574 break;
2576 case N_Others_Choice:
2577 break;
2579 default:
2580 gcc_unreachable ();
2583 /* Everything should be folded into constants at this point. */
2584 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
2585 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
2587 if (gnu_low && TREE_TYPE (gnu_low) != gnu_type)
2588 gnu_low = convert (gnu_type, gnu_low);
2589 if (gnu_high && TREE_TYPE (gnu_high) != gnu_type)
2590 gnu_high = convert (gnu_type, gnu_high);
2592 add_stmt_with_node (build_case_label (gnu_low, gnu_high, label),
2593 gnat_choice);
2594 choices_added_p = true;
2597 /* This construct doesn't define a scope so we shouldn't push a binding
2598 level around the statement list. Except that we have always done so
2599 historically and this makes it possible to reduce stack usage. As a
2600 compromise, we keep doing it for case statements, for which this has
2601 never been problematic, but not for case expressions in Ada 2012. */
2602 if (choices_added_p)
2604 const bool is_case_expression
2605 = (Nkind (Parent (gnat_node)) == N_Expression_With_Actions);
2606 tree group
2607 = build_stmt_group (Statements (gnat_when), !is_case_expression);
2608 bool group_may_fallthru = block_may_fallthru (group);
2609 add_stmt (group);
2610 if (group_may_fallthru)
2612 tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2613 SET_EXPR_LOCATION (stmt, end_locus);
2614 add_stmt (stmt);
2615 may_fallthru = true;
2620 /* Now emit a definition of the label the cases branch to, if any. */
2621 if (may_fallthru)
2622 add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2623 gnu_result
2624 = build3 (SWITCH_EXPR, gnu_type, gnu_expr, end_stmt_group (), NULL_TREE);
2626 return gnu_result;
2629 /* Return true if we are in the body of a loop. */
2631 static inline bool
2632 inside_loop_p (void)
2634 return !vec_safe_is_empty (gnu_loop_stack);
2637 /* Find out whether EXPR is a simple additive expression based on the iteration
2638 variable of some enclosing loop in the current function. If so, return the
2639 loop and set *DISP to the displacement and *NEG_P to true if this is for a
2640 subtraction; otherwise, return NULL. */
2642 static struct loop_info_d *
2643 find_loop_for (tree expr, tree *disp = NULL, bool *neg_p = NULL)
2645 tree var, add, cst;
2646 bool minus_p;
2647 struct loop_info_d *iter = NULL;
2648 unsigned int i;
2650 if (is_simple_additive_expression (expr, &add, &cst, &minus_p))
2652 var = add;
2653 if (disp)
2654 *disp = cst;
2655 if (neg_p)
2656 *neg_p = minus_p;
2658 else
2660 var = expr;
2661 if (disp)
2662 *disp = NULL_TREE;
2663 if (neg_p)
2664 *neg_p = false;
2667 var = remove_conversions (var, false);
2669 if (TREE_CODE (var) != VAR_DECL)
2670 return NULL;
2672 if (decl_function_context (var) != current_function_decl)
2673 return NULL;
2675 gcc_assert (vec_safe_length (gnu_loop_stack) > 0);
2677 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
2678 if (var == iter->loop_var)
2679 break;
2681 return iter;
2684 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2685 false, or the maximum value if MAX is true, of TYPE. */
2687 static bool
2688 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2690 tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2692 if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2693 return true;
2695 if (TREE_CODE (val) == NOP_EXPR)
2696 val = (max
2697 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2698 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2700 if (TREE_CODE (val) != INTEGER_CST)
2701 return true;
2703 if (max)
2704 return tree_int_cst_lt (val, min_or_max_val) == 0;
2705 else
2706 return tree_int_cst_lt (min_or_max_val, val) == 0;
2709 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2710 If REVERSE is true, minimum value is taken as maximum value. */
2712 static inline bool
2713 can_equal_min_val_p (tree val, tree type, bool reverse)
2715 return can_equal_min_or_max_val_p (val, type, reverse);
2718 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2719 If REVERSE is true, maximum value is taken as minimum value. */
2721 static inline bool
2722 can_equal_max_val_p (tree val, tree type, bool reverse)
2724 return can_equal_min_or_max_val_p (val, type, !reverse);
2727 /* Return true if VAL1 can be lower than VAL2. */
2729 static bool
2730 can_be_lower_p (tree val1, tree val2)
2732 if (TREE_CODE (val1) == NOP_EXPR)
2733 val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2735 if (TREE_CODE (val1) != INTEGER_CST)
2736 return true;
2738 if (TREE_CODE (val2) == NOP_EXPR)
2739 val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2741 if (TREE_CODE (val2) != INTEGER_CST)
2742 return true;
2744 return tree_int_cst_lt (val1, val2);
2747 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
2748 true if both expressions have been replaced and false otherwise. */
2750 static bool
2751 make_invariant (tree *expr1, tree *expr2)
2753 tree inv_expr1 = gnat_invariant_expr (*expr1);
2754 tree inv_expr2 = gnat_invariant_expr (*expr2);
2756 if (inv_expr1)
2757 *expr1 = inv_expr1;
2759 if (inv_expr2)
2760 *expr2 = inv_expr2;
2762 return inv_expr1 && inv_expr2;
2765 /* Helper function for walk_tree, used by independent_iterations_p below. */
2767 static tree
2768 scan_rhs_r (tree *tp, int *walk_subtrees, void *data)
2770 bitmap *params = (bitmap *)data;
2771 tree t = *tp;
2773 /* No need to walk into types or decls. */
2774 if (IS_TYPE_OR_DECL_P (t))
2775 *walk_subtrees = 0;
2777 if (TREE_CODE (t) == PARM_DECL && bitmap_bit_p (*params, DECL_UID (t)))
2778 return t;
2780 return NULL_TREE;
2783 /* Return true if STMT_LIST generates independent iterations in a loop. */
2785 static bool
2786 independent_iterations_p (tree stmt_list)
2788 tree_stmt_iterator tsi;
2789 bitmap params = BITMAP_GGC_ALLOC();
2790 auto_vec<tree> rhs;
2791 tree iter;
2792 int i;
2794 if (TREE_CODE (stmt_list) == BIND_EXPR)
2795 stmt_list = BIND_EXPR_BODY (stmt_list);
2797 /* Scan the list and return false on anything that is not either a check
2798 or an assignment to a parameter with restricted aliasing. */
2799 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
2801 tree stmt = tsi_stmt (tsi);
2803 switch (TREE_CODE (stmt))
2805 case COND_EXPR:
2807 if (COND_EXPR_ELSE (stmt))
2808 return false;
2809 if (TREE_CODE (COND_EXPR_THEN (stmt)) != CALL_EXPR)
2810 return false;
2811 tree func = get_callee_fndecl (COND_EXPR_THEN (stmt));
2812 if (!(func && TREE_THIS_VOLATILE (func)))
2813 return false;
2814 break;
2817 case MODIFY_EXPR:
2819 tree lhs = TREE_OPERAND (stmt, 0);
2820 while (handled_component_p (lhs))
2821 lhs = TREE_OPERAND (lhs, 0);
2822 if (TREE_CODE (lhs) != INDIRECT_REF)
2823 return false;
2824 lhs = TREE_OPERAND (lhs, 0);
2825 if (!(TREE_CODE (lhs) == PARM_DECL
2826 && DECL_RESTRICTED_ALIASING_P (lhs)))
2827 return false;
2828 bitmap_set_bit (params, DECL_UID (lhs));
2829 rhs.safe_push (TREE_OPERAND (stmt, 1));
2830 break;
2833 default:
2834 return false;
2838 /* At this point we know that the list contains only statements that will
2839 modify parameters with restricted aliasing. Check that the statements
2840 don't at the time read from these parameters. */
2841 FOR_EACH_VEC_ELT (rhs, i, iter)
2842 if (walk_tree_without_duplicates (&iter, scan_rhs_r, &params))
2843 return false;
2845 return true;
2848 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2849 to a GCC tree, which is returned. */
2851 static tree
2852 Loop_Statement_to_gnu (Node_Id gnat_node)
2854 const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2855 struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
2856 tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2857 NULL_TREE, NULL_TREE, NULL_TREE);
2858 tree gnu_loop_label = create_artificial_label (input_location);
2859 tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2860 tree gnu_result;
2862 /* Push the loop_info structure associated with the LOOP_STMT. */
2863 vec_safe_push (gnu_loop_stack, gnu_loop_info);
2865 /* Set location information for statement and end label. */
2866 set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2867 Sloc_to_locus (Sloc (End_Label (gnat_node)),
2868 &DECL_SOURCE_LOCATION (gnu_loop_label));
2869 LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2871 /* Save the statement for later reuse. */
2872 gnu_loop_info->stmt = gnu_loop_stmt;
2873 gnu_loop_info->artificial = !Comes_From_Source (gnat_node);
2875 /* Set the condition under which the loop must keep going.
2876 For the case "LOOP .... END LOOP;" the condition is always true. */
2877 if (No (gnat_iter_scheme))
2880 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2881 else if (Present (Condition (gnat_iter_scheme)))
2882 LOOP_STMT_COND (gnu_loop_stmt)
2883 = gnat_to_gnu (Condition (gnat_iter_scheme));
2885 /* Otherwise we have an iteration scheme and the condition is given by the
2886 bounds of the subtype of the iteration variable. */
2887 else
2889 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2890 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2891 Entity_Id gnat_type = Etype (gnat_loop_var);
2892 tree gnu_type = get_unpadded_type (gnat_type);
2893 tree gnu_base_type = maybe_character_type (get_base_type (gnu_type));
2894 tree gnu_one_node = build_int_cst (gnu_base_type, 1);
2895 tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2896 enum tree_code update_code, test_code, shift_code;
2897 bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2899 gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type));
2900 gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type));
2902 /* We must disable modulo reduction for the iteration variable, if any,
2903 in order for the loop comparison to be effective. */
2904 if (reverse)
2906 gnu_first = gnu_high;
2907 gnu_last = gnu_low;
2908 update_code = MINUS_NOMOD_EXPR;
2909 test_code = GE_EXPR;
2910 shift_code = PLUS_NOMOD_EXPR;
2912 else
2914 gnu_first = gnu_low;
2915 gnu_last = gnu_high;
2916 update_code = PLUS_NOMOD_EXPR;
2917 test_code = LE_EXPR;
2918 shift_code = MINUS_NOMOD_EXPR;
2921 /* We use two different strategies to translate the loop, depending on
2922 whether optimization is enabled.
2924 If it is, we generate the canonical loop form expected by the loop
2925 optimizer and the loop vectorizer, which is the do-while form:
2927 ENTRY_COND
2928 loop:
2929 TOP_UPDATE
2930 BODY
2931 BOTTOM_COND
2932 GOTO loop
2934 This avoids an implicit dependency on loop header copying and makes
2935 it possible to turn BOTTOM_COND into an inequality test.
2937 If optimization is disabled, loop header copying doesn't come into
2938 play and we try to generate the loop form with the fewer conditional
2939 branches. First, the default form, which is:
2941 loop:
2942 TOP_COND
2943 BODY
2944 BOTTOM_UPDATE
2945 GOTO loop
2947 It should catch most loops with constant ending point. Then, if we
2948 cannot, we try to generate the shifted form:
2950 loop:
2951 TOP_COND
2952 TOP_UPDATE
2953 BODY
2954 GOTO loop
2956 which should catch loops with constant starting point. Otherwise, if
2957 we cannot, we generate the fallback form:
2959 ENTRY_COND
2960 loop:
2961 BODY
2962 BOTTOM_COND
2963 BOTTOM_UPDATE
2964 GOTO loop
2966 which works in all cases. */
2968 if (optimize)
2970 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
2971 overflow. */
2972 if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2975 /* Otherwise, use the do-while form with the help of a special
2976 induction variable in the unsigned version of the base type
2977 or the unsigned version of the size type, whichever is the
2978 largest, in order to have wrap-around arithmetics for it. */
2979 else
2981 if (TYPE_PRECISION (gnu_base_type)
2982 > TYPE_PRECISION (size_type_node))
2983 gnu_base_type
2984 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1);
2985 else
2986 gnu_base_type = size_type_node;
2988 gnu_first = convert (gnu_base_type, gnu_first);
2989 gnu_last = convert (gnu_base_type, gnu_last);
2990 gnu_one_node = build_int_cst (gnu_base_type, 1);
2991 use_iv = true;
2994 gnu_first
2995 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2996 gnu_one_node);
2997 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2998 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3000 else
3002 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
3003 if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
3006 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
3007 GNU_LAST-1 does. */
3008 else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
3009 && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
3011 gnu_first
3012 = build_binary_op (shift_code, gnu_base_type, gnu_first,
3013 gnu_one_node);
3014 gnu_last
3015 = build_binary_op (shift_code, gnu_base_type, gnu_last,
3016 gnu_one_node);
3017 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
3020 /* Otherwise, use the fallback form. */
3021 else
3022 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3025 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3026 test but we may have to add ENTRY_COND to protect the empty loop. */
3027 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
3029 test_code = NE_EXPR;
3030 if (can_be_lower_p (gnu_high, gnu_low))
3032 gnu_cond_expr
3033 = build3 (COND_EXPR, void_type_node,
3034 build_binary_op (LE_EXPR, boolean_type_node,
3035 gnu_low, gnu_high),
3036 NULL_TREE, alloc_stmt_list ());
3037 set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
3041 /* Open a new nesting level that will surround the loop to declare the
3042 iteration variable. */
3043 start_stmt_group ();
3044 gnat_pushlevel ();
3046 /* If we use the special induction variable, create it and set it to
3047 its initial value. Morever, the regular iteration variable cannot
3048 itself be initialized, lest the initial value wrapped around. */
3049 if (use_iv)
3051 gnu_loop_iv
3052 = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
3053 add_stmt (gnu_stmt);
3054 gnu_first = NULL_TREE;
3056 else
3057 gnu_loop_iv = NULL_TREE;
3059 /* Declare the iteration variable and set it to its initial value. */
3060 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, true);
3061 if (DECL_BY_REF_P (gnu_loop_var))
3062 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
3063 else if (use_iv)
3065 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
3066 SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
3068 gnu_loop_info->loop_var = gnu_loop_var;
3069 gnu_loop_info->low_bound = gnu_low;
3070 gnu_loop_info->high_bound = gnu_high;
3072 /* Do all the arithmetics in the base type. */
3073 gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
3075 /* Set either the top or bottom exit condition. */
3076 if (use_iv)
3077 LOOP_STMT_COND (gnu_loop_stmt)
3078 = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
3079 gnu_last);
3080 else
3081 LOOP_STMT_COND (gnu_loop_stmt)
3082 = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
3083 gnu_last);
3085 /* Set either the top or bottom update statement and give it the source
3086 location of the iteration for better coverage info. */
3087 if (use_iv)
3089 gnu_stmt
3090 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
3091 build_binary_op (update_code, gnu_base_type,
3092 gnu_loop_iv, gnu_one_node));
3093 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3094 append_to_statement_list (gnu_stmt,
3095 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3096 gnu_stmt
3097 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3098 gnu_loop_iv);
3099 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3100 append_to_statement_list (gnu_stmt,
3101 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3103 else
3105 gnu_stmt
3106 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3107 build_binary_op (update_code, gnu_base_type,
3108 gnu_loop_var, gnu_one_node));
3109 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3110 LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
3114 /* If the loop was named, have the name point to this loop. In this case,
3115 the association is not a DECL node, but the end label of the loop. */
3116 if (Present (Identifier (gnat_node)))
3117 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
3119 /* Make the loop body into its own block, so any allocated storage will be
3120 released every iteration. This is needed for stack allocation. */
3121 LOOP_STMT_BODY (gnu_loop_stmt)
3122 = build_stmt_group (Statements (gnat_node), true);
3123 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
3125 /* If we have an iteration scheme, then we are in a statement group. Add
3126 the LOOP_STMT to it, finish it and make it the "loop". */
3127 if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
3129 /* First, if we have computed invariant conditions for range (or index)
3130 checks applied to the iteration variable, find out whether they can
3131 be evaluated to false at compile time; otherwise, if there are not
3132 too many of them, combine them with the original checks. If loop
3133 unswitching is enabled, do not require the loop bounds to be also
3134 invariant, as their evaluation will still be ahead of the loop. */
3135 if (vec_safe_length (gnu_loop_info->checks) > 0
3136 && (make_invariant (&gnu_low, &gnu_high) || flag_unswitch_loops))
3138 struct range_check_info_d *rci;
3139 unsigned int i, n_remaining_checks = 0;
3141 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3143 tree low_ok, high_ok;
3145 if (rci->low_bound)
3147 tree gnu_adjusted_low = convert (rci->type, gnu_low);
3148 if (rci->disp)
3149 gnu_adjusted_low
3150 = fold_build2 (rci->neg_p ? MINUS_EXPR : PLUS_EXPR,
3151 rci->type, gnu_adjusted_low, rci->disp);
3152 low_ok
3153 = build_binary_op (GE_EXPR, boolean_type_node,
3154 gnu_adjusted_low, rci->low_bound);
3156 else
3157 low_ok = boolean_true_node;
3159 if (rci->high_bound)
3161 tree gnu_adjusted_high = convert (rci->type, gnu_high);
3162 if (rci->disp)
3163 gnu_adjusted_high
3164 = fold_build2 (rci->neg_p ? MINUS_EXPR : PLUS_EXPR,
3165 rci->type, gnu_adjusted_high, rci->disp);
3166 high_ok
3167 = build_binary_op (LE_EXPR, boolean_type_node,
3168 gnu_adjusted_high, rci->high_bound);
3170 else
3171 high_ok = boolean_true_node;
3173 tree range_ok
3174 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
3175 low_ok, high_ok);
3177 rci->invariant_cond
3178 = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
3180 if (rci->invariant_cond == boolean_false_node)
3181 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3182 else
3183 n_remaining_checks++;
3186 /* Note that loop unswitching can only be applied a small number of
3187 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3188 if (0 < n_remaining_checks && n_remaining_checks <= 3
3189 && optimize > 1 && !optimize_size)
3190 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3191 if (rci->invariant_cond != boolean_false_node)
3193 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3195 if (flag_unswitch_loops)
3196 add_stmt_with_node_force (rci->inserted_cond, gnat_node);
3200 /* Second, if loop vectorization is enabled and the iterations of the
3201 loop can easily be proved as independent, mark the loop. */
3202 if (optimize
3203 && flag_tree_loop_vectorize
3204 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt)))
3205 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
3207 add_stmt (gnu_loop_stmt);
3208 gnat_poplevel ();
3209 gnu_loop_stmt = end_stmt_group ();
3212 /* If we have an outer COND_EXPR, that's our result and this loop is its
3213 "true" statement. Otherwise, the result is the LOOP_STMT. */
3214 if (gnu_cond_expr)
3216 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
3217 TREE_SIDE_EFFECTS (gnu_cond_expr) = 1;
3218 gnu_result = gnu_cond_expr;
3220 else
3221 gnu_result = gnu_loop_stmt;
3223 gnu_loop_stack->pop ();
3225 return gnu_result;
3228 /* This page implements a form of Named Return Value optimization modelled
3229 on the C++ optimization of the same name. The main difference is that
3230 we disregard any semantical considerations when applying it here, the
3231 counterpart being that we don't try to apply it to semantically loaded
3232 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3234 We consider a function body of the following GENERIC form:
3236 return_type R1;
3237 [...]
3238 RETURN_EXPR [<retval> = ...]
3239 [...]
3240 RETURN_EXPR [<retval> = R1]
3241 [...]
3242 return_type Ri;
3243 [...]
3244 RETURN_EXPR [<retval> = ...]
3245 [...]
3246 RETURN_EXPR [<retval> = Ri]
3247 [...]
3249 where the Ri are not addressable and we try to fulfill a simple criterion
3250 that would make it possible to replace one or several Ri variables by the
3251 single RESULT_DECL of the function.
3253 The first observation is that RETURN_EXPRs that don't directly reference
3254 any of the Ri variables on the RHS of their assignment are transparent wrt
3255 the optimization. This is because the Ri variables aren't addressable so
3256 any transformation applied to them doesn't affect the RHS; moreover, the
3257 assignment writes the full <retval> object so existing values are entirely
3258 discarded.
3260 This property can be extended to some forms of RETURN_EXPRs that reference
3261 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3262 case, in particular when function calls are involved.
3264 Therefore the algorithm is as follows:
3266 1. Collect the list of candidates for a Named Return Value (Ri variables
3267 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3268 other expressions on the RHS of such assignments.
3270 2. Prune the members of the first list (candidates) that are referenced
3271 by a member of the second list (expressions).
3273 3. Extract a set of candidates with non-overlapping live ranges from the
3274 first list. These are the Named Return Values.
3276 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3277 Named Return Values in the function with the RESULT_DECL.
3279 If the function returns an unconstrained type, things are a bit different
3280 because the anonymous return object is allocated on the secondary stack
3281 and RESULT_DECL is only a pointer to it. Each return object can be of a
3282 different size and is allocated separately so we need not care about the
3283 addressability and the aforementioned overlapping issues. Therefore, we
3284 don't collect the other expressions and skip step #2 in the algorithm. */
3286 struct nrv_data
3288 bitmap nrv;
3289 tree result;
3290 Node_Id gnat_ret;
3291 hash_set<tree> *visited;
3294 /* Return true if T is a Named Return Value. */
3296 static inline bool
3297 is_nrv_p (bitmap nrv, tree t)
3299 return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
3302 /* Helper function for walk_tree, used by finalize_nrv below. */
3304 static tree
3305 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
3307 struct nrv_data *dp = (struct nrv_data *)data;
3308 tree t = *tp;
3310 /* No need to walk into types or decls. */
3311 if (IS_TYPE_OR_DECL_P (t))
3312 *walk_subtrees = 0;
3314 if (is_nrv_p (dp->nrv, t))
3315 bitmap_clear_bit (dp->nrv, DECL_UID (t));
3317 return NULL_TREE;
3320 /* Prune Named Return Values in BLOCK and return true if there is still a
3321 Named Return Value in BLOCK or one of its sub-blocks. */
3323 static bool
3324 prune_nrv_in_block (bitmap nrv, tree block)
3326 bool has_nrv = false;
3327 tree t;
3329 /* First recurse on the sub-blocks. */
3330 for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
3331 has_nrv |= prune_nrv_in_block (nrv, t);
3333 /* Then make sure to keep at most one NRV per block. */
3334 for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
3335 if (is_nrv_p (nrv, t))
3337 if (has_nrv)
3338 bitmap_clear_bit (nrv, DECL_UID (t));
3339 else
3340 has_nrv = true;
3343 return has_nrv;
3346 /* Helper function for walk_tree, used by finalize_nrv below. */
3348 static tree
3349 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
3351 struct nrv_data *dp = (struct nrv_data *)data;
3352 tree t = *tp;
3354 /* No need to walk into types. */
3355 if (TYPE_P (t))
3356 *walk_subtrees = 0;
3358 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3359 nop, but differs from using NULL_TREE in that it indicates that we care
3360 about the value of the RESULT_DECL. */
3361 else if (TREE_CODE (t) == RETURN_EXPR
3362 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3364 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3366 /* Strip useless conversions around the return value. */
3367 if (gnat_useless_type_conversion (ret_val))
3368 ret_val = TREE_OPERAND (ret_val, 0);
3370 if (is_nrv_p (dp->nrv, ret_val))
3371 TREE_OPERAND (t, 0) = dp->result;
3374 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3375 if needed. */
3376 else if (TREE_CODE (t) == DECL_EXPR
3377 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3379 tree var = DECL_EXPR_DECL (t), init;
3381 if (DECL_INITIAL (var))
3383 init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
3384 DECL_INITIAL (var));
3385 SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
3386 DECL_INITIAL (var) = NULL_TREE;
3388 else
3389 init = build_empty_stmt (EXPR_LOCATION (t));
3390 *tp = init;
3392 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3393 SET_DECL_VALUE_EXPR (var, dp->result);
3394 DECL_HAS_VALUE_EXPR_P (var) = 1;
3395 /* ??? Kludge to avoid an assertion failure during inlining. */
3396 DECL_SIZE (var) = bitsize_unit_node;
3397 DECL_SIZE_UNIT (var) = size_one_node;
3400 /* And replace all uses of NRVs with the RESULT_DECL. */
3401 else if (is_nrv_p (dp->nrv, t))
3402 *tp = convert (TREE_TYPE (t), dp->result);
3404 /* Avoid walking into the same tree more than once. Unfortunately, we
3405 can't just use walk_tree_without_duplicates because it would only
3406 call us for the first occurrence of NRVs in the function body. */
3407 if (dp->visited->add (*tp))
3408 *walk_subtrees = 0;
3410 return NULL_TREE;
3413 /* Likewise, but used when the function returns an unconstrained type. */
3415 static tree
3416 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
3418 struct nrv_data *dp = (struct nrv_data *)data;
3419 tree t = *tp;
3421 /* No need to walk into types. */
3422 if (TYPE_P (t))
3423 *walk_subtrees = 0;
3425 /* We need to see the DECL_EXPR of NRVs before any other references so we
3426 walk the body of BIND_EXPR before walking its variables. */
3427 else if (TREE_CODE (t) == BIND_EXPR)
3428 walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
3430 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3431 return value built by the allocator instead of the whole construct. */
3432 else if (TREE_CODE (t) == RETURN_EXPR
3433 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3435 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3437 /* This is the construct returned by the allocator. */
3438 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3439 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
3441 tree rhs = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3443 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
3444 ret_val = CONSTRUCTOR_ELT (rhs, 1)->value;
3445 else
3446 ret_val = rhs;
3449 /* Strip useless conversions around the return value. */
3450 if (gnat_useless_type_conversion (ret_val)
3451 || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
3452 ret_val = TREE_OPERAND (ret_val, 0);
3454 /* Strip unpadding around the return value. */
3455 if (TREE_CODE (ret_val) == COMPONENT_REF
3456 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
3457 ret_val = TREE_OPERAND (ret_val, 0);
3459 /* Assign the new return value to the RESULT_DECL. */
3460 if (is_nrv_p (dp->nrv, ret_val))
3461 TREE_OPERAND (TREE_OPERAND (t, 0), 1)
3462 = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
3465 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3466 into a new variable. */
3467 else if (TREE_CODE (t) == DECL_EXPR
3468 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3470 tree saved_current_function_decl = current_function_decl;
3471 tree var = DECL_EXPR_DECL (t);
3472 tree alloc, p_array, new_var, new_ret;
3473 vec<constructor_elt, va_gc> *v;
3474 vec_alloc (v, 2);
3476 /* Create an artificial context to build the allocation. */
3477 current_function_decl = decl_function_context (var);
3478 start_stmt_group ();
3479 gnat_pushlevel ();
3481 /* This will return a COMPOUND_EXPR with the allocation in the first
3482 arm and the final return value in the second arm. */
3483 alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
3484 TREE_TYPE (dp->result),
3485 Procedure_To_Call (dp->gnat_ret),
3486 Storage_Pool (dp->gnat_ret),
3487 Empty, false);
3489 /* The new variable is built as a reference to the allocated space. */
3490 new_var
3491 = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
3492 build_reference_type (TREE_TYPE (var)));
3493 DECL_BY_REFERENCE (new_var) = 1;
3495 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
3497 tree cst = TREE_OPERAND (alloc, 1);
3499 /* The new initial value is a COMPOUND_EXPR with the allocation in
3500 the first arm and the value of P_ARRAY in the second arm. */
3501 DECL_INITIAL (new_var)
3502 = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
3503 TREE_OPERAND (alloc, 0),
3504 CONSTRUCTOR_ELT (cst, 0)->value);
3506 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3507 p_array = TYPE_FIELDS (TREE_TYPE (alloc));
3508 CONSTRUCTOR_APPEND_ELT (v, p_array,
3509 fold_convert (TREE_TYPE (p_array), new_var));
3510 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
3511 CONSTRUCTOR_ELT (cst, 1)->value);
3512 new_ret = build_constructor (TREE_TYPE (alloc), v);
3514 else
3516 /* The new initial value is just the allocation. */
3517 DECL_INITIAL (new_var) = alloc;
3518 new_ret = fold_convert (TREE_TYPE (alloc), new_var);
3521 gnat_pushdecl (new_var, Empty);
3523 /* Destroy the artificial context and insert the new statements. */
3524 gnat_zaplevel ();
3525 *tp = end_stmt_group ();
3526 current_function_decl = saved_current_function_decl;
3528 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3529 DECL_CHAIN (new_var) = DECL_CHAIN (var);
3530 DECL_CHAIN (var) = new_var;
3531 DECL_IGNORED_P (var) = 1;
3533 /* Save the new return value and the dereference of NEW_VAR. */
3534 DECL_INITIAL (var)
3535 = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
3536 build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
3537 /* ??? Kludge to avoid messing up during inlining. */
3538 DECL_CONTEXT (var) = NULL_TREE;
3541 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3542 else if (is_nrv_p (dp->nrv, t))
3543 *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3545 /* Avoid walking into the same tree more than once. Unfortunately, we
3546 can't just use walk_tree_without_duplicates because it would only
3547 call us for the first occurrence of NRVs in the function body. */
3548 if (dp->visited->add (*tp))
3549 *walk_subtrees = 0;
3551 return NULL_TREE;
3554 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3555 contains the candidates for Named Return Value and OTHER is a list of
3556 the other return values. GNAT_RET is a representative return node. */
3558 static void
3559 finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret)
3561 struct cgraph_node *node;
3562 struct nrv_data data;
3563 walk_tree_fn func;
3564 unsigned int i;
3565 tree iter;
3567 /* We shouldn't be applying the optimization to return types that we aren't
3568 allowed to manipulate freely. */
3569 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3571 /* Prune the candidates that are referenced by other return values. */
3572 data.nrv = nrv;
3573 data.result = NULL_TREE;
3574 data.gnat_ret = Empty;
3575 data.visited = NULL;
3576 FOR_EACH_VEC_SAFE_ELT (other, i, iter)
3577 walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3578 if (bitmap_empty_p (nrv))
3579 return;
3581 /* Prune also the candidates that are referenced by nested functions. */
3582 node = cgraph_node::get_create (fndecl);
3583 for (node = node->nested; node; node = node->next_nested)
3584 walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r,
3585 &data);
3586 if (bitmap_empty_p (nrv))
3587 return;
3589 /* Extract a set of NRVs with non-overlapping live ranges. */
3590 if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3591 return;
3593 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3594 data.nrv = nrv;
3595 data.result = DECL_RESULT (fndecl);
3596 data.gnat_ret = gnat_ret;
3597 data.visited = new hash_set<tree>;
3598 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3599 func = finalize_nrv_unc_r;
3600 else
3601 func = finalize_nrv_r;
3602 walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3603 delete data.visited;
3606 /* Return true if RET_VAL can be used as a Named Return Value for the
3607 anonymous return object RET_OBJ. */
3609 static bool
3610 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3612 if (TREE_CODE (ret_val) != VAR_DECL)
3613 return false;
3615 if (TREE_THIS_VOLATILE (ret_val))
3616 return false;
3618 if (DECL_CONTEXT (ret_val) != current_function_decl)
3619 return false;
3621 if (TREE_STATIC (ret_val))
3622 return false;
3624 /* For the constrained case, test for addressability. */
3625 if (ret_obj && TREE_ADDRESSABLE (ret_val))
3626 return false;
3628 /* For the constrained case, test for overalignment. */
3629 if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3630 return false;
3632 /* For the unconstrained case, test for bogus initialization. */
3633 if (!ret_obj
3634 && DECL_INITIAL (ret_val)
3635 && TREE_CODE (DECL_INITIAL (ret_val)) == NULL_EXPR)
3636 return false;
3638 return true;
3641 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3642 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3643 around RESULT_OBJ, which may be null in this case. */
3645 static tree
3646 build_return_expr (tree ret_obj, tree ret_val)
3648 tree result_expr;
3650 if (ret_val)
3652 /* The gimplifier explicitly enforces the following invariant:
3654 RETURN_EXPR
3656 INIT_EXPR
3659 RET_OBJ ...
3661 As a consequence, type consistency dictates that we use the type
3662 of the RET_OBJ as the operation type. */
3663 tree operation_type = TREE_TYPE (ret_obj);
3665 /* Convert the right operand to the operation type. Note that this is
3666 the transformation applied in the INIT_EXPR case of build_binary_op,
3667 with the assumption that the type cannot involve a placeholder. */
3668 if (operation_type != TREE_TYPE (ret_val))
3669 ret_val = convert (operation_type, ret_val);
3671 /* We always can use an INIT_EXPR for the return object. */
3672 result_expr = build2 (INIT_EXPR, void_type_node, ret_obj, ret_val);
3674 /* If the function returns an aggregate type, find out whether this is
3675 a candidate for Named Return Value. If so, record it. Otherwise,
3676 if this is an expression of some kind, record it elsewhere. */
3677 if (optimize
3678 && AGGREGATE_TYPE_P (operation_type)
3679 && !TYPE_IS_FAT_POINTER_P (operation_type)
3680 && TYPE_MODE (operation_type) == BLKmode
3681 && aggregate_value_p (operation_type, current_function_decl))
3683 /* Strip useless conversions around the return value. */
3684 if (gnat_useless_type_conversion (ret_val))
3685 ret_val = TREE_OPERAND (ret_val, 0);
3687 /* Now apply the test to the return value. */
3688 if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3690 if (!f_named_ret_val)
3691 f_named_ret_val = BITMAP_GGC_ALLOC ();
3692 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3695 /* Note that we need not care about CONSTRUCTORs here, as they are
3696 totally transparent given the read-compose-write semantics of
3697 assignments from CONSTRUCTORs. */
3698 else if (EXPR_P (ret_val))
3699 vec_safe_push (f_other_ret_val, ret_val);
3702 else
3703 result_expr = ret_obj;
3705 return build1 (RETURN_EXPR, void_type_node, result_expr);
3708 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3709 don't return anything. */
3711 static void
3712 Subprogram_Body_to_gnu (Node_Id gnat_node)
3714 /* Defining identifier of a parameter to the subprogram. */
3715 Entity_Id gnat_param;
3716 /* The defining identifier for the subprogram body. Note that if a
3717 specification has appeared before for this body, then the identifier
3718 occurring in that specification will also be a defining identifier and all
3719 the calls to this subprogram will point to that specification. */
3720 Entity_Id gnat_subprog_id
3721 = (Present (Corresponding_Spec (gnat_node))
3722 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3723 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3724 tree gnu_subprog_decl;
3725 /* Its RESULT_DECL node. */
3726 tree gnu_result_decl;
3727 /* Its FUNCTION_TYPE node. */
3728 tree gnu_subprog_type;
3729 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3730 tree gnu_cico_list;
3731 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3732 tree gnu_return_var_elmt = NULL_TREE;
3733 tree gnu_result;
3734 location_t locus;
3735 struct language_function *gnu_subprog_language;
3736 vec<parm_attr, va_gc> *cache;
3738 /* If this is a generic object or if it has been eliminated,
3739 ignore it. */
3740 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
3741 || Ekind (gnat_subprog_id) == E_Generic_Function
3742 || Is_Eliminated (gnat_subprog_id))
3743 return;
3745 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3746 the already-elaborated tree node. However, if this subprogram had its
3747 elaboration deferred, we will already have made a tree node for it. So
3748 treat it as not being defined in that case. Such a subprogram cannot
3749 have an address clause or a freeze node, so this test is safe, though it
3750 does disable some otherwise-useful error checking. */
3751 gnu_subprog_decl
3752 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
3753 Acts_As_Spec (gnat_node)
3754 && !present_gnu_tree (gnat_subprog_id));
3755 DECL_FUNCTION_IS_DEF (gnu_subprog_decl) = true;
3756 gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
3757 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
3758 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3759 if (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node)
3760 gnu_return_var_elmt = gnu_cico_list;
3762 /* If the function returns by invisible reference, make it explicit in the
3763 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
3764 if (TREE_ADDRESSABLE (gnu_subprog_type))
3766 TREE_TYPE (gnu_result_decl)
3767 = build_reference_type (TREE_TYPE (gnu_result_decl));
3768 relayout_decl (gnu_result_decl);
3771 /* Set the line number in the decl to correspond to that of the body. */
3772 Sloc_to_locus (Sloc (gnat_node), &locus);
3773 DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus;
3775 /* Initialize the information structure for the function. */
3776 allocate_struct_function (gnu_subprog_decl, false);
3777 gnu_subprog_language = ggc_cleared_alloc<language_function> ();
3778 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
3779 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_start_locus = locus;
3780 set_cfun (NULL);
3782 begin_subprog_body (gnu_subprog_decl);
3784 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3785 properly copied out by the return statement. We do this by making a new
3786 block and converting any return into a goto to a label at the end of the
3787 block. */
3788 if (gnu_cico_list)
3790 tree gnu_return_var = NULL_TREE;
3792 vec_safe_push (gnu_return_label_stack,
3793 create_artificial_label (input_location));
3795 start_stmt_group ();
3796 gnat_pushlevel ();
3798 /* If this is a function with copy-in/copy-out parameters and which does
3799 not return by invisible reference, we also need a variable for the
3800 return value to be placed. */
3801 if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type))
3803 tree gnu_return_type
3804 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3806 gnu_return_var
3807 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3808 gnu_return_type, NULL_TREE,
3809 false, false, false, false, false,
3810 true, false, NULL, gnat_subprog_id);
3811 TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3814 vec_safe_push (gnu_return_var_stack, gnu_return_var);
3816 /* See whether there are parameters for which we don't have a GCC tree
3817 yet. These must be Out parameters. Make a VAR_DECL for them and
3818 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3819 We can match up the entries because TYPE_CI_CO_LIST is in the order
3820 of the parameters. */
3821 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3822 Present (gnat_param);
3823 gnat_param = Next_Formal_With_Extras (gnat_param))
3824 if (!present_gnu_tree (gnat_param))
3826 tree gnu_cico_entry = gnu_cico_list;
3827 tree gnu_decl;
3829 /* Skip any entries that have been already filled in; they must
3830 correspond to In Out parameters. */
3831 while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3832 gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3834 /* Do any needed dereferences for by-ref objects. */
3835 gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, true);
3836 gcc_assert (DECL_P (gnu_decl));
3837 if (DECL_BY_REF_P (gnu_decl))
3838 gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
3840 /* Do any needed references for padded types. */
3841 TREE_VALUE (gnu_cico_entry)
3842 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl);
3845 else
3846 vec_safe_push (gnu_return_label_stack, NULL_TREE);
3848 /* Get a tree corresponding to the code for the subprogram. */
3849 start_stmt_group ();
3850 gnat_pushlevel ();
3852 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3854 /* Generate the code of the subprogram itself. A return statement will be
3855 present and any Out parameters will be handled there. */
3856 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3857 gnat_poplevel ();
3858 gnu_result = end_stmt_group ();
3860 /* If we populated the parameter attributes cache, we need to make sure that
3861 the cached expressions are evaluated on all the possible paths leading to
3862 their uses. So we force their evaluation on entry of the function. */
3863 cache = gnu_subprog_language->parm_attr_cache;
3864 if (cache)
3866 struct parm_attr_d *pa;
3867 int i;
3869 start_stmt_group ();
3871 FOR_EACH_VEC_ELT (*cache, i, pa)
3873 if (pa->first)
3874 add_stmt_with_node_force (pa->first, gnat_node);
3875 if (pa->last)
3876 add_stmt_with_node_force (pa->last, gnat_node);
3877 if (pa->length)
3878 add_stmt_with_node_force (pa->length, gnat_node);
3881 add_stmt (gnu_result);
3882 gnu_result = end_stmt_group ();
3884 gnu_subprog_language->parm_attr_cache = NULL;
3887 /* If we are dealing with a return from an Ada procedure with parameters
3888 passed by copy-in/copy-out, we need to return a record containing the
3889 final values of these parameters. If the list contains only one entry,
3890 return just that entry though.
3892 For a full description of the copy-in/copy-out parameter mechanism, see
3893 the part of the gnat_to_gnu_entity routine dealing with the translation
3894 of subprograms.
3896 We need to make a block that contains the definition of that label and
3897 the copying of the return value. It first contains the function, then
3898 the label and copy statement. */
3899 if (gnu_cico_list)
3901 const Node_Id gnat_end_label
3902 = End_Label (Handled_Statement_Sequence (gnat_node));
3904 gnu_return_var_stack->pop ();
3906 add_stmt (gnu_result);
3907 add_stmt (build1 (LABEL_EXPR, void_type_node,
3908 gnu_return_label_stack->last ()));
3910 /* If this is a function which returns by invisible reference, the
3911 return value has already been dealt with at the return statements,
3912 so we only need to indirectly copy out the parameters. */
3913 if (TREE_ADDRESSABLE (gnu_subprog_type))
3915 tree gnu_ret_deref
3916 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl);
3917 tree t;
3919 gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node);
3921 for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t))
3923 tree gnu_field_deref
3924 = build_component_ref (gnu_ret_deref, TREE_PURPOSE (t), true);
3925 gnu_result = build2 (MODIFY_EXPR, void_type_node,
3926 gnu_field_deref, TREE_VALUE (t));
3927 add_stmt_with_node (gnu_result, gnat_end_label);
3931 /* Otherwise, if this is a procedure or a function which does not return
3932 by invisible reference, we can do a direct block-copy out. */
3933 else
3935 tree gnu_retval;
3937 if (list_length (gnu_cico_list) == 1)
3938 gnu_retval = TREE_VALUE (gnu_cico_list);
3939 else
3940 gnu_retval
3941 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
3942 gnu_cico_list);
3944 gnu_result = build_return_expr (gnu_result_decl, gnu_retval);
3945 add_stmt_with_node (gnu_result, gnat_end_label);
3948 gnat_poplevel ();
3949 gnu_result = end_stmt_group ();
3952 gnu_return_label_stack->pop ();
3954 /* Attempt setting the end_locus of our GCC body tree, typically a
3955 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
3956 declaration tree. */
3957 set_end_locus_from_node (gnu_result, gnat_node);
3958 set_end_locus_from_node (gnu_subprog_decl, gnat_node);
3960 /* On SEH targets, install an exception handler around the main entry
3961 point to catch unhandled exceptions. */
3962 if (DECL_NAME (gnu_subprog_decl) == main_identifier_node
3963 && targetm_common.except_unwind_info (&global_options) == UI_SEH)
3965 tree t;
3966 tree etype;
3968 t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
3969 1, integer_zero_node);
3970 t = build_call_n_expr (unhandled_except_decl, 1, t);
3972 etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl);
3973 etype = tree_cons (NULL_TREE, etype, NULL_TREE);
3975 t = build2 (CATCH_EXPR, void_type_node, etype, t);
3976 gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result),
3977 gnu_result, t);
3980 end_subprog_body (gnu_result);
3982 /* Finally annotate the parameters and disconnect the trees for parameters
3983 that we have turned into variables since they are now unusable. */
3984 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3985 Present (gnat_param);
3986 gnat_param = Next_Formal_With_Extras (gnat_param))
3988 tree gnu_param = get_gnu_tree (gnat_param);
3989 bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
3991 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
3992 DECL_BY_REF_P (gnu_param));
3994 if (is_var_decl)
3995 save_gnu_tree (gnat_param, NULL_TREE, false);
3998 /* Disconnect the variable created for the return value. */
3999 if (gnu_return_var_elmt)
4000 TREE_VALUE (gnu_return_var_elmt) = void_type_node;
4002 /* If the function returns an aggregate type and we have candidates for
4003 a Named Return Value, finalize the optimization. */
4004 if (optimize && gnu_subprog_language->named_ret_val)
4006 finalize_nrv (gnu_subprog_decl,
4007 gnu_subprog_language->named_ret_val,
4008 gnu_subprog_language->other_ret_val,
4009 gnu_subprog_language->gnat_ret);
4010 gnu_subprog_language->named_ret_val = NULL;
4011 gnu_subprog_language->other_ret_val = NULL;
4014 /* If this is an inlined external function that has been marked uninlinable,
4015 drop the body and stop there. Otherwise compile the body. */
4016 if (DECL_EXTERNAL (gnu_subprog_decl) && DECL_UNINLINABLE (gnu_subprog_decl))
4017 DECL_SAVED_TREE (gnu_subprog_decl) = NULL_TREE;
4018 else
4019 rest_of_subprog_body_compilation (gnu_subprog_decl);
4022 /* Return true if GNAT_NODE references an Atomic entity. */
4024 static bool
4025 node_is_atomic (Node_Id gnat_node)
4027 Entity_Id gnat_entity;
4029 switch (Nkind (gnat_node))
4031 case N_Identifier:
4032 case N_Expanded_Name:
4033 gnat_entity = Entity (gnat_node);
4034 if (Ekind (gnat_entity) != E_Variable)
4035 break;
4036 return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
4038 case N_Selected_Component:
4039 gnat_entity = Entity (Selector_Name (gnat_node));
4040 return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
4042 case N_Indexed_Component:
4043 if (Has_Atomic_Components (Etype (Prefix (gnat_node))))
4044 return true;
4045 if (Is_Entity_Name (Prefix (gnat_node))
4046 && Has_Atomic_Components (Entity (Prefix (gnat_node))))
4047 return true;
4049 /* ... fall through ... */
4051 case N_Explicit_Dereference:
4052 return Is_Atomic (Etype (gnat_node));
4054 default:
4055 break;
4058 return false;
4061 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. */
4063 static bool
4064 node_has_volatile_full_access (Node_Id gnat_node)
4066 Entity_Id gnat_entity;
4068 switch (Nkind (gnat_node))
4070 case N_Identifier:
4071 case N_Expanded_Name:
4072 gnat_entity = Entity (gnat_node);
4073 if (Ekind (gnat_entity) != E_Variable)
4074 break;
4075 return Is_Volatile_Full_Access (gnat_entity)
4076 || Is_Volatile_Full_Access (Etype (gnat_entity));
4078 case N_Selected_Component:
4079 gnat_entity = Entity (Selector_Name (gnat_node));
4080 return Is_Volatile_Full_Access (gnat_entity)
4081 || Is_Volatile_Full_Access (Etype (gnat_entity));
4083 case N_Indexed_Component:
4084 case N_Explicit_Dereference:
4085 return Is_Volatile_Full_Access (Etype (gnat_node));
4087 default:
4088 break;
4091 return false;
4094 /* Strip any type conversion on GNAT_NODE and return the result. */
4096 static Node_Id
4097 gnat_strip_type_conversion (Node_Id gnat_node)
4099 Node_Kind kind = Nkind (gnat_node);
4101 if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
4102 gnat_node = Expression (gnat_node);
4104 return gnat_node;
4107 /* Return true if GNAT_NODE requires outer atomic access, i.e. atomic access
4108 of an object of which GNAT_NODE is a component. */
4110 static bool
4111 outer_atomic_access_required_p (Node_Id gnat_node)
4113 gnat_node = gnat_strip_type_conversion (gnat_node);
4115 while (true)
4117 switch (Nkind (gnat_node))
4119 case N_Identifier:
4120 case N_Expanded_Name:
4121 if (No (Renamed_Object (Entity (gnat_node))))
4122 return false;
4123 gnat_node
4124 = gnat_strip_type_conversion (Renamed_Object (Entity (gnat_node)));
4125 break;
4127 case N_Indexed_Component:
4128 case N_Selected_Component:
4129 case N_Slice:
4130 gnat_node = gnat_strip_type_conversion (Prefix (gnat_node));
4131 if (node_has_volatile_full_access (gnat_node))
4132 return true;
4133 break;
4135 default:
4136 return false;
4140 gcc_unreachable ();
4143 /* Return true if GNAT_NODE requires atomic access and set SYNC according to
4144 the associated synchronization setting. */
4146 static bool
4147 atomic_access_required_p (Node_Id gnat_node, bool *sync)
4149 const Node_Id gnat_parent = Parent (gnat_node);
4150 unsigned char attr_id;
4151 bool as_a_whole = true;
4153 /* First, scan the parent to find out cases where the flag is irrelevant. */
4154 switch (Nkind (gnat_parent))
4156 case N_Attribute_Reference:
4157 attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
4158 /* Do not mess up machine code insertions. */
4159 if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
4160 return false;
4162 /* Nothing to do if we are the prefix of an attribute, since we do not
4163 want an atomic access for things like 'Size. */
4165 /* ... fall through ... */
4167 case N_Reference:
4168 /* The N_Reference node is like an attribute. */
4169 if (Prefix (gnat_parent) == gnat_node)
4170 return false;
4171 break;
4173 case N_Indexed_Component:
4174 case N_Selected_Component:
4175 case N_Slice:
4176 /* If we are the prefix, then the access is only partial. */
4177 if (Prefix (gnat_parent) == gnat_node)
4178 as_a_whole = false;
4179 break;
4181 case N_Object_Renaming_Declaration:
4182 /* Nothing to do for the identifier in an object renaming declaration,
4183 the renaming itself does not need atomic access. */
4184 return false;
4186 default:
4187 break;
4190 /* Then, scan the node to find the atomic object. */
4191 gnat_node = gnat_strip_type_conversion (gnat_node);
4193 /* For Atomic itself, only reads and updates of the object as a whole require
4194 atomic access (RM C.6 (15)). But for Volatile_Full_Access, all reads and
4195 updates require atomic access. */
4196 if (!(as_a_whole && node_is_atomic (gnat_node))
4197 && !node_has_volatile_full_access (gnat_node))
4198 return false;
4200 /* If an outer atomic access will also be required, it cancels this one. */
4201 if (outer_atomic_access_required_p (gnat_node))
4202 return false;
4204 *sync = Atomic_Sync_Required (gnat_node);
4206 return true;
4209 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4211 static tree
4212 create_temporary (const char *prefix, tree type)
4214 tree gnu_temp
4215 = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
4216 type, NULL_TREE,
4217 false, false, false, false, false,
4218 true, false, NULL, Empty);
4219 return gnu_temp;
4222 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4223 Put the initialization statement into GNU_INIT_STMT and annotate it with
4224 the SLOC of GNAT_NODE. Return the temporary variable. */
4226 static tree
4227 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
4228 Node_Id gnat_node)
4230 tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
4232 *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
4233 set_expr_location_from_node (*gnu_init_stmt, gnat_node);
4235 return gnu_temp;
4238 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4239 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4240 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4241 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4242 N_Assignment_Statement and the result is to be placed into that object.
4243 If OUTER_ATOMIC_ACCESS is true, then the assignment to GNU_TARGET must be a
4244 load-modify-store sequence. Otherwise, if ATOMIC_ACCESS is true, then the
4245 assignment to GNU_TARGET must be atomic. If, in addition, ATOMIC_SYNC is
4246 true, then the assignment to GNU_TARGET requires atomic synchronization. */
4248 static tree
4249 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
4250 bool outer_atomic_access, bool atomic_access, bool atomic_sync)
4252 const bool function_call = (Nkind (gnat_node) == N_Function_Call);
4253 const bool returning_value = (function_call && !gnu_target);
4254 /* The GCC node corresponding to the GNAT subprogram name. This can either
4255 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4256 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4257 subprogram. */
4258 tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
4259 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4260 tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
4261 /* The return type of the FUNCTION_TYPE. */
4262 tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
4263 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
4264 vec<tree, va_gc> *gnu_actual_vec = NULL;
4265 tree gnu_name_list = NULL_TREE;
4266 tree gnu_stmt_list = NULL_TREE;
4267 tree gnu_after_list = NULL_TREE;
4268 tree gnu_retval = NULL_TREE;
4269 tree gnu_call, gnu_result;
4270 bool by_descriptor = false;
4271 bool went_into_elab_proc = false;
4272 bool pushed_binding_level = false;
4273 Entity_Id gnat_formal;
4274 Node_Id gnat_actual;
4275 bool sync;
4277 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
4279 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
4280 all our args first. */
4281 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
4283 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
4284 gnat_node, N_Raise_Program_Error);
4286 for (gnat_actual = First_Actual (gnat_node);
4287 Present (gnat_actual);
4288 gnat_actual = Next_Actual (gnat_actual))
4289 add_stmt (gnat_to_gnu (gnat_actual));
4291 if (returning_value)
4293 *gnu_result_type_p = gnu_result_type;
4294 return build1 (NULL_EXPR, gnu_result_type, call_expr);
4297 return call_expr;
4300 /* For a call to a nested function, check the inlining status. */
4301 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL
4302 && decl_function_context (gnu_subprog))
4303 check_inlining_for_nested_subprog (gnu_subprog);
4305 /* The only way we can be making a call via an access type is if Name is an
4306 explicit dereference. In that case, get the list of formal args from the
4307 type the access type is pointing to. Otherwise, get the formals from the
4308 entity being called. */
4309 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4311 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4313 /* If the access type doesn't require foreign-compatible representation,
4314 be prepared for descriptors. */
4315 if (targetm.calls.custom_function_descriptors > 0
4316 && Can_Use_Internal_Rep (Etype (Prefix (Name (gnat_node)))))
4317 by_descriptor = true;
4319 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
4320 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4321 gnat_formal = Empty;
4322 else
4323 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4325 /* The lifetime of the temporaries created for the call ends right after the
4326 return value is copied, so we can give them the scope of the elaboration
4327 routine at top level. */
4328 if (!current_function_decl)
4330 current_function_decl = get_elaboration_procedure ();
4331 went_into_elab_proc = true;
4334 /* First, create the temporary for the return value when:
4336 1. There is no target and the function has copy-in/copy-out parameters,
4337 because we need to preserve the return value before copying back the
4338 parameters.
4340 2. There is no target and the call is made for neither an object nor a
4341 renaming declaration, nor a return statement, and the return type has
4342 variable size, because in this case the gimplifier cannot create the
4343 temporary, or more generally is simply an aggregate type, because the
4344 gimplifier would create the temporary in the outermost scope instead
4345 of locally.
4347 3. There is a target and it is a slice or an array with fixed size,
4348 and the return type has variable size, because the gimplifier
4349 doesn't handle these cases.
4351 4. There is no target and we have misaligned In Out or Out parameters
4352 passed by reference, because we need to preserve the return value
4353 before copying back the parameters. However, in this case, we'll
4354 defer creating the temporary, see below.
4356 This must be done before we push a binding level around the call, since
4357 we will pop it before copying the return value. */
4358 if (function_call
4359 && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
4360 || (!gnu_target
4361 && Nkind (Parent (gnat_node)) != N_Object_Declaration
4362 && Nkind (Parent (gnat_node)) != N_Object_Renaming_Declaration
4363 && Nkind (Parent (gnat_node)) != N_Simple_Return_Statement
4364 && AGGREGATE_TYPE_P (gnu_result_type)
4365 && !TYPE_IS_FAT_POINTER_P (gnu_result_type))
4366 || (gnu_target
4367 && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
4368 || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
4369 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
4370 == INTEGER_CST))
4371 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
4373 gnu_retval = create_temporary ("R", gnu_result_type);
4374 DECL_RETURN_VALUE_P (gnu_retval) = 1;
4377 /* If we don't need a value or have already created it, push a binding level
4378 around the call. This will narrow the lifetime of the temporaries we may
4379 need to make when translating the parameters as much as possible. */
4380 if (!returning_value || gnu_retval)
4382 start_stmt_group ();
4383 gnat_pushlevel ();
4384 pushed_binding_level = true;
4387 /* Create the list of the actual parameters as GCC expects it, namely a
4388 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4389 is an expression and the TREE_PURPOSE field is null. But skip Out
4390 parameters not passed by reference and that need not be copied in. */
4391 for (gnat_actual = First_Actual (gnat_node);
4392 Present (gnat_actual);
4393 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4394 gnat_actual = Next_Actual (gnat_actual))
4396 Entity_Id gnat_formal_type = Etype (gnat_formal);
4397 tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
4398 tree gnu_formal = present_gnu_tree (gnat_formal)
4399 ? get_gnu_tree (gnat_formal) : NULL_TREE;
4400 const bool is_true_formal_parm
4401 = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
4402 const bool is_by_ref_formal_parm
4403 = is_true_formal_parm
4404 && (DECL_BY_REF_P (gnu_formal)
4405 || DECL_BY_COMPONENT_PTR_P (gnu_formal));
4406 /* In the Out or In Out case, we must suppress conversions that yield
4407 an lvalue but can nevertheless cause the creation of a temporary,
4408 because we need the real object in this case, either to pass its
4409 address if it's passed by reference or as target of the back copy
4410 done after the call if it uses the copy-in/copy-out mechanism.
4411 We do it in the In case too, except for an unchecked conversion
4412 to an elementary type or a constrained composite type because it
4413 alone can cause the actual to be misaligned and the addressability
4414 test is applied to the real object. */
4415 const bool suppress_type_conversion
4416 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
4417 && (Ekind (gnat_formal) != E_In_Parameter
4418 || (Is_Composite_Type (Underlying_Type (gnat_formal_type))
4419 && !Is_Constrained (Underlying_Type (gnat_formal_type)))))
4420 || (Nkind (gnat_actual) == N_Type_Conversion
4421 && Is_Composite_Type (Underlying_Type (gnat_formal_type))));
4422 Node_Id gnat_name = suppress_type_conversion
4423 ? Expression (gnat_actual) : gnat_actual;
4424 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
4426 /* If it's possible we may need to use this expression twice, make sure
4427 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4428 to force side-effects before the call. */
4429 if (Ekind (gnat_formal) != E_In_Parameter && !is_by_ref_formal_parm)
4431 tree init = NULL_TREE;
4432 gnu_name = gnat_stabilize_reference (gnu_name, true, &init);
4433 if (init)
4434 gnu_name
4435 = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
4438 /* If we are passing a non-addressable parameter by reference, pass the
4439 address of a copy. In the Out or In Out case, set up to copy back
4440 out after the call. */
4441 if (is_by_ref_formal_parm
4442 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
4443 && !addressable_p (gnu_name, gnu_name_type))
4445 bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
4446 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
4448 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4449 but sort of an instantiation for them. */
4450 if (TREE_CODE (gnu_name) == CONSTRUCTOR)
4453 /* If the type is passed by reference, a copy is not allowed. */
4454 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type))
4455 post_error ("misaligned actual cannot be passed by reference",
4456 gnat_actual);
4458 /* For users of Starlet we issue a warning because the interface
4459 apparently assumes that by-ref parameters outlive the procedure
4460 invocation. The code still will not work as intended, but we
4461 cannot do much better since low-level parts of the back-end
4462 would allocate temporaries at will because of the misalignment
4463 if we did not do so here. */
4464 else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
4466 post_error
4467 ("?possible violation of implicit assumption", gnat_actual);
4468 post_error_ne
4469 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
4470 Entity (Name (gnat_node)));
4471 post_error_ne ("?because of misalignment of &", gnat_actual,
4472 gnat_formal);
4475 /* If the actual type of the object is already the nominal type,
4476 we have nothing to do, except if the size is self-referential
4477 in which case we'll remove the unpadding below. */
4478 if (TREE_TYPE (gnu_name) == gnu_name_type
4479 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
4482 /* Otherwise remove the unpadding from all the objects. */
4483 else if (TREE_CODE (gnu_name) == COMPONENT_REF
4484 && TYPE_IS_PADDING_P
4485 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
4486 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
4488 /* Otherwise convert to the nominal type of the object if needed.
4489 There are several cases in which we need to make the temporary
4490 using this type instead of the actual type of the object when
4491 they are distinct, because the expectations of the callee would
4492 otherwise not be met:
4493 - if it's a justified modular type,
4494 - if the actual type is a smaller form of it,
4495 - if it's a smaller form of the actual type. */
4496 else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
4497 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
4498 || smaller_form_type_p (TREE_TYPE (gnu_name),
4499 gnu_name_type)))
4500 || (INTEGRAL_TYPE_P (gnu_name_type)
4501 && smaller_form_type_p (gnu_name_type,
4502 TREE_TYPE (gnu_name))))
4503 gnu_name = convert (gnu_name_type, gnu_name);
4505 /* If this is an In Out or Out parameter and we're returning a value,
4506 we need to create a temporary for the return value because we must
4507 preserve it before copying back at the very end. */
4508 if (!in_param && returning_value && !gnu_retval)
4510 gnu_retval = create_temporary ("R", gnu_result_type);
4511 DECL_RETURN_VALUE_P (gnu_retval) = 1;
4514 /* If we haven't pushed a binding level, push it now. This will
4515 narrow the lifetime of the temporary we are about to make as
4516 much as possible. */
4517 if (!pushed_binding_level && (!returning_value || gnu_retval))
4519 start_stmt_group ();
4520 gnat_pushlevel ();
4521 pushed_binding_level = true;
4524 /* Create an explicit temporary holding the copy. */
4525 gnu_temp
4526 = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
4528 /* But initialize it on the fly like for an implicit temporary as
4529 we aren't necessarily having a statement list. */
4530 gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
4531 gnu_temp);
4533 /* Set up to move the copy back to the original if needed. */
4534 if (!in_param)
4536 /* If the original is a COND_EXPR whose first arm isn't meant to
4537 be further used, just deal with the second arm. This is very
4538 likely the conditional expression built for a check. */
4539 if (TREE_CODE (gnu_orig) == COND_EXPR
4540 && TREE_CODE (TREE_OPERAND (gnu_orig, 1)) == COMPOUND_EXPR
4541 && integer_zerop
4542 (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
4543 gnu_orig = TREE_OPERAND (gnu_orig, 2);
4545 gnu_stmt
4546 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
4547 set_expr_location_from_node (gnu_stmt, gnat_node);
4549 append_to_statement_list (gnu_stmt, &gnu_after_list);
4553 /* Start from the real object and build the actual. */
4554 tree gnu_actual = gnu_name;
4556 /* If atomic access is required for an In or In Out actual parameter,
4557 build the atomic load. */
4558 if (is_true_formal_parm
4559 && !is_by_ref_formal_parm
4560 && Ekind (gnat_formal) != E_Out_Parameter
4561 && atomic_access_required_p (gnat_actual, &sync))
4562 gnu_actual = build_atomic_load (gnu_actual, sync);
4564 /* If this was a procedure call, we may not have removed any padding.
4565 So do it here for the part we will use as an input, if any. */
4566 if (Ekind (gnat_formal) != E_Out_Parameter
4567 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4568 gnu_actual
4569 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
4571 /* Put back the conversion we suppressed above in the computation of the
4572 real object. And even if we didn't suppress any conversion there, we
4573 may have suppressed a conversion to the Etype of the actual earlier,
4574 since the parent is a procedure call, so put it back here. Note that
4575 we might have a dummy type here if the actual is the dereference of a
4576 pointer to it, but that's OK if the formal is passed by reference. */
4577 tree gnu_actual_type = gnat_to_gnu_type (Etype (gnat_actual));
4578 if (TYPE_IS_DUMMY_P (gnu_actual_type))
4579 gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal));
4580 else if (suppress_type_conversion
4581 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4582 gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual,
4583 No_Truncation (gnat_actual));
4584 else
4585 gnu_actual = convert (gnu_actual_type, gnu_actual);
4587 /* Make sure that the actual is in range of the formal's type. */
4588 if (Ekind (gnat_formal) != E_Out_Parameter
4589 && Do_Range_Check (gnat_actual))
4590 gnu_actual
4591 = emit_range_check (gnu_actual, gnat_formal_type, gnat_actual);
4593 /* Unless this is an In parameter, we must remove any justified modular
4594 building from GNU_NAME to get an lvalue. */
4595 if (Ekind (gnat_formal) != E_In_Parameter
4596 && TREE_CODE (gnu_name) == CONSTRUCTOR
4597 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
4598 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
4599 gnu_name
4600 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
4602 /* First see if the parameter is passed by reference. */
4603 if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
4605 if (Ekind (gnat_formal) != E_In_Parameter)
4607 /* In Out or Out parameters passed by reference don't use the
4608 copy-in/copy-out mechanism so the address of the real object
4609 must be passed to the function. */
4610 gnu_actual = gnu_name;
4612 /* If we have a padded type, be sure we've removed padding. */
4613 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4614 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
4615 gnu_actual);
4617 /* If we have the constructed subtype of an aliased object
4618 with an unconstrained nominal subtype, the type of the
4619 actual includes the template, although it is formally
4620 constrained. So we need to convert it back to the real
4621 constructed subtype to retrieve the constrained part
4622 and takes its address. */
4623 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
4624 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
4625 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
4626 && Is_Array_Type (Underlying_Type (Etype (gnat_actual))))
4627 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
4628 gnu_actual);
4631 /* There is no need to convert the actual to the formal's type before
4632 taking its address. The only exception is for unconstrained array
4633 types because of the way we build fat pointers. */
4634 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4636 /* Put back a view conversion for In Out or Out parameters. */
4637 if (Ekind (gnat_formal) != E_In_Parameter)
4638 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
4639 gnu_actual);
4640 gnu_actual = convert (gnu_formal_type, gnu_actual);
4643 /* The symmetry of the paths to the type of an entity is broken here
4644 since arguments don't know that they will be passed by ref. */
4645 gnu_formal_type = TREE_TYPE (gnu_formal);
4646 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4649 /* Then see if the parameter is an array passed to a foreign convention
4650 subprogram. */
4651 else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
4653 gnu_formal_type = TREE_TYPE (gnu_formal);
4654 gnu_actual = maybe_implicit_deref (gnu_actual);
4655 gnu_actual = maybe_unconstrained_array (gnu_actual);
4657 if (TYPE_IS_PADDING_P (gnu_formal_type))
4659 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
4660 gnu_actual = convert (gnu_formal_type, gnu_actual);
4663 /* Take the address of the object and convert to the proper pointer
4664 type. We'd like to actually compute the address of the beginning
4665 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4666 possibility that the ARRAY_REF might return a constant and we'd be
4667 getting the wrong address. Neither approach is exactly correct,
4668 but this is the most likely to work in all cases. */
4669 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4672 /* Otherwise the parameter is passed by copy. */
4673 else
4675 tree gnu_size;
4677 if (Ekind (gnat_formal) != E_In_Parameter)
4678 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
4680 /* If we didn't create a PARM_DECL for the formal, this means that
4681 it is an Out parameter not passed by reference and that need not
4682 be copied in. In this case, the value of the actual need not be
4683 read. However, we still need to make sure that its side-effects
4684 are evaluated before the call, so we evaluate its address. */
4685 if (!is_true_formal_parm)
4687 if (TREE_SIDE_EFFECTS (gnu_name))
4689 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
4690 append_to_statement_list (addr, &gnu_stmt_list);
4692 continue;
4695 gnu_actual = convert (gnu_formal_type, gnu_actual);
4697 /* If this is 'Null_Parameter, pass a zero even though we are
4698 dereferencing it. */
4699 if (TREE_CODE (gnu_actual) == INDIRECT_REF
4700 && TREE_PRIVATE (gnu_actual)
4701 && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
4702 && TREE_CODE (gnu_size) == INTEGER_CST
4703 && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
4705 tree type_for_size
4706 = gnat_type_for_size (TREE_INT_CST_LOW (gnu_size), 1);
4707 gnu_actual
4708 = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
4709 build_int_cst (type_for_size, 0),
4710 false);
4712 else
4713 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
4716 vec_safe_push (gnu_actual_vec, gnu_actual);
4719 gnu_call
4720 = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
4721 CALL_EXPR_BY_DESCRIPTOR (gnu_call) = by_descriptor;
4722 set_expr_location_from_node (gnu_call, gnat_node);
4724 /* If we have created a temporary for the return value, initialize it. */
4725 if (gnu_retval)
4727 tree gnu_stmt
4728 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
4729 set_expr_location_from_node (gnu_stmt, gnat_node);
4730 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4731 gnu_call = gnu_retval;
4734 /* If this is a subprogram with copy-in/copy-out parameters, we need to
4735 unpack the valued returned from the function into the In Out or Out
4736 parameters. We deal with the function return (if this is an Ada
4737 function) below. */
4738 if (TYPE_CI_CO_LIST (gnu_subprog_type))
4740 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
4741 copy-out parameters. */
4742 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
4743 const int length = list_length (gnu_cico_list);
4745 /* The call sequence must contain one and only one call, even though the
4746 function is pure. Save the result into a temporary if needed. */
4747 if (length > 1)
4749 if (!gnu_retval)
4751 tree gnu_stmt;
4752 gnu_call
4753 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
4754 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4757 gnu_name_list = nreverse (gnu_name_list);
4760 /* The first entry is for the actual return value if this is a
4761 function, so skip it. */
4762 if (function_call)
4763 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4765 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4766 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4767 else
4768 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4770 for (gnat_actual = First_Actual (gnat_node);
4771 Present (gnat_actual);
4772 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4773 gnat_actual = Next_Actual (gnat_actual))
4774 /* If we are dealing with a copy-in/copy-out parameter, we must
4775 retrieve its value from the record returned in the call. */
4776 if (!(present_gnu_tree (gnat_formal)
4777 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
4778 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
4779 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))))
4780 && Ekind (gnat_formal) != E_In_Parameter)
4782 /* Get the value to assign to this Out or In Out parameter. It is
4783 either the result of the function if there is only a single such
4784 parameter or the appropriate field from the record returned. */
4785 tree gnu_result
4786 = length == 1
4787 ? gnu_call
4788 : build_component_ref (gnu_call, TREE_PURPOSE (gnu_cico_list),
4789 false);
4791 /* If the actual is a conversion, get the inner expression, which
4792 will be the real destination, and convert the result to the
4793 type of the actual parameter. */
4794 tree gnu_actual
4795 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
4797 /* If the result is a padded type, remove the padding. */
4798 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4799 gnu_result
4800 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4801 gnu_result);
4803 /* If the actual is a type conversion, the real target object is
4804 denoted by the inner Expression and we need to convert the
4805 result to the associated type.
4806 We also need to convert our gnu assignment target to this type
4807 if the corresponding GNU_NAME was constructed from the GNAT
4808 conversion node and not from the inner Expression. */
4809 if (Nkind (gnat_actual) == N_Type_Conversion)
4811 gnu_result
4812 = convert_with_check
4813 (Etype (Expression (gnat_actual)), gnu_result,
4814 Do_Overflow_Check (gnat_actual),
4815 Do_Range_Check (Expression (gnat_actual)),
4816 Float_Truncate (gnat_actual), gnat_actual);
4818 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
4819 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
4822 /* Unchecked conversions as actuals for Out parameters are not
4823 allowed in user code because they are not variables, but do
4824 occur in front-end expansions. The associated GNU_NAME is
4825 always obtained from the inner expression in such cases. */
4826 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4827 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
4828 gnu_result,
4829 No_Truncation (gnat_actual));
4830 else
4832 if (Do_Range_Check (gnat_actual))
4833 gnu_result
4834 = emit_range_check (gnu_result, Etype (gnat_actual),
4835 gnat_actual);
4837 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
4838 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
4839 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
4842 /* If an outer atomic access is required for an actual parameter,
4843 build the load-modify-store sequence. */
4844 if (outer_atomic_access_required_p (gnat_actual))
4845 gnu_result
4846 = build_load_modify_store (gnu_actual, gnu_result, gnat_node);
4848 /* Or else, if simple atomic access is required, build the atomic
4849 store. */
4850 else if (atomic_access_required_p (gnat_actual, &sync))
4851 gnu_result = build_atomic_store (gnu_actual, gnu_result, sync);
4853 /* Otherwise build a regular assignment. */
4854 else
4855 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
4856 gnu_actual, gnu_result);
4858 if (EXPR_P (gnu_result))
4859 set_expr_location_from_node (gnu_result, gnat_node);
4860 append_to_statement_list (gnu_result, &gnu_stmt_list);
4861 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4862 gnu_name_list = TREE_CHAIN (gnu_name_list);
4866 /* If this is a function call, the result is the call expression unless a
4867 target is specified, in which case we copy the result into the target
4868 and return the assignment statement. */
4869 if (function_call)
4871 /* If this is a function with copy-in/copy-out parameters, extract the
4872 return value from it and update the return type. */
4873 if (TYPE_CI_CO_LIST (gnu_subprog_type))
4875 tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
4876 gnu_call
4877 = build_component_ref (gnu_call, TREE_PURPOSE (gnu_elmt), false);
4878 gnu_result_type = TREE_TYPE (gnu_call);
4881 /* If the function returns an unconstrained array or by direct reference,
4882 we have to dereference the pointer. */
4883 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
4884 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
4885 gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
4887 if (gnu_target)
4889 Node_Id gnat_parent = Parent (gnat_node);
4890 enum tree_code op_code;
4892 /* If range check is needed, emit code to generate it. */
4893 if (Do_Range_Check (gnat_node))
4894 gnu_call
4895 = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
4896 gnat_parent);
4898 /* ??? If the return type has variable size, then force the return
4899 slot optimization as we would not be able to create a temporary.
4900 That's what has been done historically. */
4901 if (return_type_with_variable_size_p (gnu_result_type))
4902 op_code = INIT_EXPR;
4903 else
4904 op_code = MODIFY_EXPR;
4906 /* Use the required method to move the result to the target. */
4907 if (outer_atomic_access)
4908 gnu_call
4909 = build_load_modify_store (gnu_target, gnu_call, gnat_node);
4910 else if (atomic_access)
4911 gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
4912 else
4913 gnu_call
4914 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
4916 if (EXPR_P (gnu_call))
4917 set_expr_location_from_node (gnu_call, gnat_parent);
4918 append_to_statement_list (gnu_call, &gnu_stmt_list);
4920 else
4921 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
4924 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
4925 parameters, the result is just the call statement. */
4926 else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
4927 append_to_statement_list (gnu_call, &gnu_stmt_list);
4929 /* Finally, add the copy back statements, if any. */
4930 append_to_statement_list (gnu_after_list, &gnu_stmt_list);
4932 if (went_into_elab_proc)
4933 current_function_decl = NULL_TREE;
4935 /* If we have pushed a binding level, pop it and finish up the enclosing
4936 statement group. */
4937 if (pushed_binding_level)
4939 add_stmt (gnu_stmt_list);
4940 gnat_poplevel ();
4941 gnu_result = end_stmt_group ();
4944 /* Otherwise, retrieve the statement list, if any. */
4945 else if (gnu_stmt_list)
4946 gnu_result = gnu_stmt_list;
4948 /* Otherwise, just return the call expression. */
4949 else
4950 return gnu_call;
4952 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
4953 But first simplify if we have only one statement in the list. */
4954 if (returning_value)
4956 tree first = expr_first (gnu_result), last = expr_last (gnu_result);
4957 if (first == last)
4958 gnu_result = first;
4959 gnu_result
4960 = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
4963 return gnu_result;
4966 /* Subroutine of gnat_to_gnu to translate gnat_node, an
4967 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
4969 static tree
4970 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
4972 tree gnu_jmpsave_decl = NULL_TREE;
4973 tree gnu_jmpbuf_decl = NULL_TREE;
4974 /* If just annotating, ignore all EH and cleanups. */
4975 bool gcc_eh = (!type_annotate_only
4976 && Present (Exception_Handlers (gnat_node))
4977 && Back_End_Exceptions ());
4978 bool fe_sjlj
4979 = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
4980 && Exception_Mechanism == Front_End_SJLJ);
4981 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
4982 bool binding_for_block = (at_end || gcc_eh || fe_sjlj);
4983 tree gnu_inner_block; /* The statement(s) for the block itself. */
4984 tree gnu_result;
4985 tree gnu_expr;
4986 Node_Id gnat_temp;
4988 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
4989 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
4990 add_cleanup, and when we leave the binding, end_stmt_group will create
4991 the TRY_FINALLY_EXPR.
4993 ??? The region level calls down there have been specifically put in place
4994 for a ZCX context and currently the order in which things are emitted
4995 (region/handlers) is different from the SJLJ case. Instead of putting
4996 other calls with different conditions at other places for the SJLJ case,
4997 it seems cleaner to reorder things for the SJLJ case and generalize the
4998 condition to make it not ZCX specific.
5000 If there are any exceptions or cleanup processing involved, we need an
5001 outer statement group (for Fe_Sjlj) and binding level. */
5002 if (binding_for_block)
5004 start_stmt_group ();
5005 gnat_pushlevel ();
5008 /* If using fe_sjlj, make the variables for the setjmp buffer and save
5009 area for address of previous buffer. Do this first since we need to have
5010 the setjmp buf known for any decls in this block. */
5011 if (fe_sjlj)
5013 gnu_jmpsave_decl
5014 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
5015 jmpbuf_ptr_type,
5016 build_call_n_expr (get_jmpbuf_decl, 0),
5017 false, false, false, false, false, true, false,
5018 NULL, gnat_node);
5020 /* The __builtin_setjmp receivers will immediately reinstall it. Now
5021 because of the unstructured form of EH used by fe_sjlj, there
5022 might be forward edges going to __builtin_setjmp receivers on which
5023 it is uninitialized, although they will never be actually taken. */
5024 TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
5025 gnu_jmpbuf_decl
5026 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
5027 jmpbuf_type,
5028 NULL_TREE,
5029 false, false, false, false, false, true, false,
5030 NULL, gnat_node);
5032 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
5034 /* When we exit this block, restore the saved value. */
5035 add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
5036 Present (End_Label (gnat_node))
5037 ? End_Label (gnat_node) : gnat_node);
5040 /* If we are to call a function when exiting this block, add a cleanup
5041 to the binding level we made above. Note that add_cleanup is FIFO
5042 so we must register this cleanup after the EH cleanup just above. */
5043 if (at_end)
5045 tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
5047 /* When not optimizing, disable inlining of finalizers as this can
5048 create a more complex CFG in the parent function. */
5049 if (!optimize)
5050 DECL_DECLARED_INLINE_P (proc_decl) = 0;
5052 /* If there is no end label attached, we use the location of the At_End
5053 procedure because Expand_Cleanup_Actions might reset the location of
5054 the enclosing construct to that of an inner statement. */
5055 add_cleanup (build_call_n_expr (proc_decl, 0),
5056 Present (End_Label (gnat_node))
5057 ? End_Label (gnat_node) : At_End_Proc (gnat_node));
5060 /* Now build the tree for the declarations and statements inside this block.
5061 If this is SJLJ, set our jmp_buf as the current buffer. */
5062 start_stmt_group ();
5064 if (fe_sjlj)
5066 gnu_expr = build_call_n_expr (set_jmpbuf_decl, 1,
5067 build_unary_op (ADDR_EXPR, NULL_TREE,
5068 gnu_jmpbuf_decl));
5069 set_expr_location_from_node (gnu_expr, gnat_node);
5070 add_stmt (gnu_expr);
5073 if (Present (First_Real_Statement (gnat_node)))
5074 process_decls (Statements (gnat_node), Empty,
5075 First_Real_Statement (gnat_node), true, true);
5077 /* Generate code for each statement in the block. */
5078 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
5079 ? First_Real_Statement (gnat_node)
5080 : First (Statements (gnat_node)));
5081 Present (gnat_temp); gnat_temp = Next (gnat_temp))
5082 add_stmt (gnat_to_gnu (gnat_temp));
5083 gnu_inner_block = end_stmt_group ();
5085 /* Now generate code for the two exception models, if either is relevant for
5086 this block. */
5087 if (fe_sjlj)
5089 tree *gnu_else_ptr = 0;
5090 tree gnu_handler;
5092 /* Make a binding level for the exception handling declarations and code
5093 and set up gnu_except_ptr_stack for the handlers to use. */
5094 start_stmt_group ();
5095 gnat_pushlevel ();
5097 vec_safe_push (gnu_except_ptr_stack,
5098 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
5099 build_pointer_type (except_type_node),
5100 build_call_n_expr (get_excptr_decl, 0),
5101 false, false, false, false, false,
5102 true, false, NULL, gnat_node));
5104 /* Generate code for each handler. The N_Exception_Handler case does the
5105 real work and returns a COND_EXPR for each handler, which we chain
5106 together here. */
5107 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5108 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
5110 gnu_expr = gnat_to_gnu (gnat_temp);
5112 /* If this is the first one, set it as the outer one. Otherwise,
5113 point the "else" part of the previous handler to us. Then point
5114 to our "else" part. */
5115 if (!gnu_else_ptr)
5116 add_stmt (gnu_expr);
5117 else
5118 *gnu_else_ptr = gnu_expr;
5120 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
5123 /* If none of the exception handlers did anything, re-raise but do not
5124 defer abortion. */
5125 gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
5126 gnu_except_ptr_stack->last ());
5127 set_expr_location_from_node
5128 (gnu_expr,
5129 Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
5131 if (gnu_else_ptr)
5132 *gnu_else_ptr = gnu_expr;
5133 else
5134 add_stmt (gnu_expr);
5136 /* End the binding level dedicated to the exception handlers and get the
5137 whole statement group. */
5138 gnu_except_ptr_stack->pop ();
5139 gnat_poplevel ();
5140 gnu_handler = end_stmt_group ();
5142 /* If the setjmp returns 1, we restore our incoming longjmp value and
5143 then check the handlers. */
5144 start_stmt_group ();
5145 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1,
5146 gnu_jmpsave_decl),
5147 gnat_node);
5148 add_stmt (gnu_handler);
5149 gnu_handler = end_stmt_group ();
5151 /* This block is now "if (setjmp) ... <handlers> else <block>". */
5152 gnu_result = build3 (COND_EXPR, void_type_node,
5153 (build_call_n_expr
5154 (setjmp_decl, 1,
5155 build_unary_op (ADDR_EXPR, NULL_TREE,
5156 gnu_jmpbuf_decl))),
5157 gnu_handler, gnu_inner_block);
5159 else if (gcc_eh)
5161 tree gnu_handlers;
5162 location_t locus;
5164 /* First make a block containing the handlers. */
5165 start_stmt_group ();
5166 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5167 Present (gnat_temp);
5168 gnat_temp = Next_Non_Pragma (gnat_temp))
5169 add_stmt (gnat_to_gnu (gnat_temp));
5170 gnu_handlers = end_stmt_group ();
5172 /* Now make the TRY_CATCH_EXPR for the block. */
5173 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
5174 gnu_inner_block, gnu_handlers);
5175 /* Set a location. We need to find a unique location for the dispatching
5176 code, otherwise we can get coverage or debugging issues. Try with
5177 the location of the end label. */
5178 if (Present (End_Label (gnat_node))
5179 && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus))
5180 SET_EXPR_LOCATION (gnu_result, locus);
5181 else
5182 /* Clear column information so that the exception handler of an
5183 implicit transient block does not incorrectly inherit the slocs
5184 of a decision, which would otherwise confuse control flow based
5185 coverage analysis tools. */
5186 set_expr_location_from_node (gnu_result, gnat_node, true);
5188 else
5189 gnu_result = gnu_inner_block;
5191 /* Now close our outer block, if we had to make one. */
5192 if (binding_for_block)
5194 add_stmt (gnu_result);
5195 gnat_poplevel ();
5196 gnu_result = end_stmt_group ();
5199 return gnu_result;
5202 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5203 to a GCC tree, which is returned. This is the variant for front-end sjlj
5204 exception handling. */
5206 static tree
5207 Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node)
5209 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5210 an "if" statement to select the proper exceptions. For "Others", exclude
5211 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5212 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5213 tree gnu_choice = boolean_false_node;
5214 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
5215 Node_Id gnat_temp;
5217 for (gnat_temp = First (Exception_Choices (gnat_node));
5218 gnat_temp; gnat_temp = Next (gnat_temp))
5220 tree this_choice;
5222 if (Nkind (gnat_temp) == N_Others_Choice)
5224 if (All_Others (gnat_temp))
5225 this_choice = boolean_true_node;
5226 else
5227 this_choice
5228 = build_binary_op
5229 (EQ_EXPR, boolean_type_node,
5230 convert
5231 (integer_type_node,
5232 build_component_ref
5233 (build_unary_op
5234 (INDIRECT_REF, NULL_TREE,
5235 gnu_except_ptr_stack->last ()),
5236 not_handled_by_others_decl,
5237 false)),
5238 integer_zero_node);
5241 else if (Nkind (gnat_temp) == N_Identifier
5242 || Nkind (gnat_temp) == N_Expanded_Name)
5244 Entity_Id gnat_ex_id = Entity (gnat_temp);
5245 tree gnu_expr;
5247 /* Exception may be a renaming. Recover original exception which is
5248 the one elaborated and registered. */
5249 if (Present (Renamed_Object (gnat_ex_id)))
5250 gnat_ex_id = Renamed_Object (gnat_ex_id);
5252 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
5254 this_choice
5255 = build_binary_op
5256 (EQ_EXPR, boolean_type_node,
5257 gnu_except_ptr_stack->last (),
5258 convert (TREE_TYPE (gnu_except_ptr_stack->last ()),
5259 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
5261 else
5262 gcc_unreachable ();
5264 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
5265 gnu_choice, this_choice);
5268 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
5271 /* Return true if no statement in GNAT_LIST can alter the control flow. */
5273 static bool
5274 stmt_list_cannot_alter_control_flow_p (List_Id gnat_list)
5276 if (No (gnat_list))
5277 return true;
5279 /* This is very conservative, we reject everything except for simple
5280 assignments between identifiers or literals. */
5281 for (Node_Id gnat_node = First (gnat_list);
5282 Present (gnat_node);
5283 gnat_node = Next (gnat_node))
5285 if (Nkind (gnat_node) != N_Assignment_Statement)
5286 return false;
5288 if (Nkind (Name (gnat_node)) != N_Identifier)
5289 return false;
5291 Node_Kind nkind = Nkind (Expression (gnat_node));
5292 if (nkind != N_Identifier
5293 && nkind != N_Integer_Literal
5294 && nkind != N_Real_Literal)
5295 return false;
5298 return true;
5301 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5302 to a GCC tree, which is returned. This is the variant for GCC exception
5303 schemes. */
5305 static tree
5306 Exception_Handler_to_gnu_gcc (Node_Id gnat_node)
5308 tree gnu_etypes_list = NULL_TREE;
5310 /* We build a TREE_LIST of nodes representing what exception types this
5311 handler can catch, with special cases for others and all others cases.
5313 Each exception type is actually identified by a pointer to the exception
5314 id, or to a dummy object for "others" and "all others". */
5315 for (Node_Id gnat_temp = First (Exception_Choices (gnat_node));
5316 gnat_temp;
5317 gnat_temp = Next (gnat_temp))
5319 tree gnu_expr, gnu_etype;
5321 if (Nkind (gnat_temp) == N_Others_Choice)
5323 gnu_expr = All_Others (gnat_temp) ? all_others_decl : others_decl;
5324 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5326 else if (Nkind (gnat_temp) == N_Identifier
5327 || Nkind (gnat_temp) == N_Expanded_Name)
5329 Entity_Id gnat_ex_id = Entity (gnat_temp);
5331 /* Exception may be a renaming. Recover original exception which is
5332 the one elaborated and registered. */
5333 if (Present (Renamed_Object (gnat_ex_id)))
5334 gnat_ex_id = Renamed_Object (gnat_ex_id);
5336 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
5337 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5339 else
5340 gcc_unreachable ();
5342 /* The GCC interface expects NULL to be passed for catch all handlers, so
5343 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5344 is integer_zero_node. It would not work, however, because GCC's
5345 notion of "catch all" is stronger than our notion of "others". Until
5346 we correctly use the cleanup interface as well, doing that would
5347 prevent the "all others" handlers from being seen, because nothing
5348 can be caught beyond a catch all from GCC's point of view. */
5349 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
5352 start_stmt_group ();
5353 gnat_pushlevel ();
5355 /* Expand a call to the begin_handler hook at the beginning of the handler,
5356 and arrange for a call to the end_handler hook to occur on every possible
5357 exit path.
5359 The hooks expect a pointer to the low level occurrence. This is required
5360 for our stack management scheme because a raise inside the handler pushes
5361 a new occurrence on top of the stack, which means that this top does not
5362 necessarily match the occurrence this handler was dealing with.
5364 __builtin_eh_pointer references the exception occurrence being
5365 propagated. Upon handler entry, this is the exception for which the
5366 handler is triggered. This might not be the case upon handler exit,
5367 however, as we might have a new occurrence propagated by the handler's
5368 body, and the end_handler hook called as a cleanup in this context.
5370 We use a local variable to retrieve the incoming value at handler entry
5371 time, and reuse it to feed the end_handler hook's argument at exit. */
5373 tree gnu_current_exc_ptr
5374 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
5375 1, integer_zero_node);
5376 tree prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
5377 gnu_incoming_exc_ptr
5378 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
5379 ptr_type_node, gnu_current_exc_ptr,
5380 false, false, false, false, false, true, true,
5381 NULL, gnat_node);
5383 add_stmt_with_node (build_call_n_expr (begin_handler_decl, 1,
5384 gnu_incoming_exc_ptr),
5385 gnat_node);
5387 /* Declare and initialize the choice parameter, if present. */
5388 if (Present (Choice_Parameter (gnat_node)))
5390 tree gnu_param
5391 = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, true);
5393 add_stmt (build_call_n_expr
5394 (set_exception_parameter_decl, 2,
5395 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param),
5396 gnu_incoming_exc_ptr));
5399 add_stmt_list (Statements (gnat_node));
5401 /* We don't have an End_Label at hand to set the location of the cleanup
5402 actions, so we use that of the exception handler itself instead. */
5403 tree stmt = build_call_n_expr (end_handler_decl, 1, gnu_incoming_exc_ptr);
5404 if (stmt_list_cannot_alter_control_flow_p (Statements (gnat_node)))
5405 add_stmt_with_node (stmt, gnat_node);
5406 else
5407 add_cleanup (stmt, gnat_node);
5409 gnat_poplevel ();
5411 gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
5413 return
5414 build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ());
5417 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5419 static void
5420 Compilation_Unit_to_gnu (Node_Id gnat_node)
5422 const Node_Id gnat_unit = Unit (gnat_node);
5423 const bool body_p = (Nkind (gnat_unit) == N_Package_Body
5424 || Nkind (gnat_unit) == N_Subprogram_Body);
5425 const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
5426 Entity_Id gnat_entity;
5427 Node_Id gnat_pragma;
5428 /* Make the decl for the elaboration procedure. Emit debug info for it, so
5429 that users can break into their elaboration code in debuggers. Kludge:
5430 don't consider it as a definition so that we have a line map for its body,
5431 but no subprogram description in debug info. */
5432 tree gnu_elab_proc_decl
5433 = create_subprog_decl
5434 (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
5435 NULL_TREE, void_ftype, NULL_TREE,
5436 is_disabled, true, false, true, true, false, NULL, gnat_unit);
5437 struct elab_info *info;
5439 vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
5440 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
5442 /* Initialize the information structure for the function. */
5443 allocate_struct_function (gnu_elab_proc_decl, false);
5444 set_cfun (NULL);
5446 current_function_decl = NULL_TREE;
5448 start_stmt_group ();
5449 gnat_pushlevel ();
5451 /* For a body, first process the spec if there is one. */
5452 if (Nkind (gnat_unit) == N_Package_Body
5453 || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
5454 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
5456 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
5458 elaborate_all_entities (gnat_node);
5460 if (Nkind (gnat_unit) == N_Subprogram_Declaration
5461 || Nkind (gnat_unit) == N_Generic_Package_Declaration
5462 || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
5463 return;
5466 /* Then process any pragmas and declarations preceding the unit. */
5467 for (gnat_pragma = First (Context_Items (gnat_node));
5468 Present (gnat_pragma);
5469 gnat_pragma = Next (gnat_pragma))
5470 if (Nkind (gnat_pragma) == N_Pragma)
5471 add_stmt (gnat_to_gnu (gnat_pragma));
5472 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
5473 true, true);
5475 /* Process the unit itself. */
5476 add_stmt (gnat_to_gnu (gnat_unit));
5478 /* Generate code for all the inlined subprograms. */
5479 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5480 Present (gnat_entity);
5481 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5483 Node_Id gnat_body;
5485 /* Without optimization, process only the required subprograms. */
5486 if (!optimize && !Has_Pragma_Inline_Always (gnat_entity))
5487 continue;
5489 /* The set of inlined subprograms is computed from data recorded early
5490 during expansion and it can be a strict superset of the final set
5491 computed after semantic analysis, for example if a call to such a
5492 subprogram occurs in a pragma Assert and assertions are disabled.
5493 In that case, semantic analysis resets Is_Public to false but the
5494 entry for the subprogram in the inlining tables is stalled. */
5495 if (!Is_Public (gnat_entity))
5496 continue;
5498 gnat_body = Parent (Declaration_Node (gnat_entity));
5499 if (Nkind (gnat_body) != N_Subprogram_Body)
5501 /* ??? This happens when only the spec of a package is provided. */
5502 if (No (Corresponding_Body (gnat_body)))
5503 continue;
5505 gnat_body
5506 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5509 /* Define the entity first so we set DECL_EXTERNAL. */
5510 gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
5511 add_stmt (gnat_to_gnu (gnat_body));
5514 /* Process any pragmas and actions following the unit. */
5515 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
5516 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
5517 finalize_from_limited_with ();
5519 /* Save away what we've made so far and finish it up. */
5520 set_current_block_context (gnu_elab_proc_decl);
5521 gnat_poplevel ();
5522 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
5523 set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
5524 gnu_elab_proc_stack->pop ();
5526 /* Record this potential elaboration procedure for later processing. */
5527 info = ggc_alloc<elab_info> ();
5528 info->next = elab_info_list;
5529 info->elab_proc = gnu_elab_proc_decl;
5530 info->gnat_node = gnat_node;
5531 elab_info_list = info;
5533 /* Force the processing for all nodes that remain in the queue. */
5534 process_deferred_decl_context (true);
5537 /* Mark COND, a boolean expression, as predicating a call to a noreturn
5538 function, i.e. predict that it is very likely false, and return it.
5540 The compiler will automatically predict the last edge leading to a call
5541 to a noreturn function as very unlikely taken. This function makes it
5542 possible to expand the prediction to predecessors in case the condition
5543 is made up of several short-circuit operators. */
5545 static tree
5546 build_noreturn_cond (tree cond)
5548 tree fn = builtin_decl_explicit (BUILT_IN_EXPECT);
5549 tree arg_types = TYPE_ARG_TYPES (TREE_TYPE (fn));
5550 tree pred_type = TREE_VALUE (arg_types);
5551 tree expected_type = TREE_VALUE (TREE_CHAIN (arg_types));
5553 tree t = build_call_expr (fn, 3,
5554 fold_convert (pred_type, cond),
5555 build_int_cst (expected_type, 0),
5556 build_int_cst (integer_type_node,
5557 PRED_NORETURN));
5559 return build1 (NOP_EXPR, boolean_type_node, t);
5562 /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
5563 range of values, into GNU_LOW and GNU_HIGH bounds. */
5565 static void
5566 Range_to_gnu (Node_Id gnat_range, tree *gnu_low, tree *gnu_high)
5568 /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
5569 switch (Nkind (gnat_range))
5571 case N_Range:
5572 *gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
5573 *gnu_high = gnat_to_gnu (High_Bound (gnat_range));
5574 break;
5576 case N_Expanded_Name:
5577 case N_Identifier:
5579 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
5580 tree gnu_range_base_type = get_base_type (gnu_range_type);
5582 *gnu_low
5583 = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
5584 *gnu_high
5585 = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
5587 break;
5589 default:
5590 gcc_unreachable ();
5594 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
5595 to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
5596 we should place the result type. */
5598 static tree
5599 Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
5601 const Node_Kind kind = Nkind (gnat_node);
5602 const int reason = UI_To_Int (Reason (gnat_node));
5603 const Node_Id gnat_cond = Condition (gnat_node);
5604 const bool with_extra_info
5605 = Exception_Extra_Info
5606 && !No_Exception_Handlers_Set ()
5607 && !get_exception_label (kind);
5608 tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
5610 /* The following processing is not required for correctness. Its purpose is
5611 to give more precise error messages and to record some information. */
5612 switch (reason)
5614 case CE_Access_Check_Failed:
5615 if (with_extra_info)
5616 gnu_result = build_call_raise_column (reason, gnat_node, kind);
5617 break;
5619 case CE_Index_Check_Failed:
5620 case CE_Range_Check_Failed:
5621 case CE_Invalid_Data:
5622 if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
5624 Node_Id gnat_index, gnat_type;
5625 tree gnu_type, gnu_index, gnu_low_bound, gnu_high_bound, disp;
5626 bool neg_p;
5627 struct loop_info_d *loop;
5629 switch (Nkind (Right_Opnd (gnat_cond)))
5631 case N_In:
5632 Range_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)),
5633 &gnu_low_bound, &gnu_high_bound);
5634 break;
5636 case N_Op_Ge:
5637 gnu_low_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
5638 gnu_high_bound = NULL_TREE;
5639 break;
5641 case N_Op_Le:
5642 gnu_low_bound = NULL_TREE;
5643 gnu_high_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
5644 break;
5646 default:
5647 goto common;
5650 gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
5651 gnat_type = Etype (gnat_index);
5652 gnu_type = maybe_character_type (get_unpadded_type (gnat_type));
5653 gnu_index = gnat_to_gnu (gnat_index);
5655 if (TREE_TYPE (gnu_index) != gnu_type)
5657 if (gnu_low_bound)
5658 gnu_low_bound = convert (gnu_type, gnu_low_bound);
5659 if (gnu_high_bound)
5660 gnu_high_bound = convert (gnu_type, gnu_high_bound);
5661 gnu_index = convert (gnu_type, gnu_index);
5664 if (with_extra_info
5665 && gnu_low_bound
5666 && gnu_high_bound
5667 && Known_Esize (gnat_type)
5668 && UI_To_Int (Esize (gnat_type)) <= 32)
5669 gnu_result
5670 = build_call_raise_range (reason, gnat_node, kind, gnu_index,
5671 gnu_low_bound, gnu_high_bound);
5673 /* If optimization is enabled and we are inside a loop, we try to
5674 compute invariant conditions for checks applied to the iteration
5675 variable, i.e. conditions that are independent of the variable
5676 and necessary in order for the checks to fail in the course of
5677 some iteration. If we succeed, we consider an alternative:
5679 1. If loop unswitching is enabled, we prepend these conditions
5680 to the original conditions of the checks. This will make it
5681 possible for the loop unswitching pass to replace the loop
5682 with two loops, one of which has the checks eliminated and
5683 the other has the original checks reinstated, and a prologue
5684 implementing a run-time selection. The former loop will be
5685 for example suitable for vectorization.
5687 2. Otherwise, we instead append the conditions to the original
5688 conditions of the checks. At worse, if the conditions cannot
5689 be evaluated at compile time, they will be evaluated as true
5690 at run time only when the checks have already failed, thus
5691 contributing negatively only to the size of the executable.
5692 But the hope is that these invariant conditions be evaluated
5693 at compile time to false, thus taking away the entire checks
5694 with them. */
5695 if (optimize
5696 && inside_loop_p ()
5697 && (!gnu_low_bound
5698 || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)))
5699 && (!gnu_high_bound
5700 || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)))
5701 && (loop = find_loop_for (gnu_index, &disp, &neg_p)))
5703 struct range_check_info_d *rci = ggc_alloc<range_check_info_d> ();
5704 rci->low_bound = gnu_low_bound;
5705 rci->high_bound = gnu_high_bound;
5706 rci->disp = disp;
5707 rci->neg_p = neg_p;
5708 rci->type = gnu_type;
5709 rci->inserted_cond
5710 = build1 (SAVE_EXPR, boolean_type_node, boolean_true_node);
5711 vec_safe_push (loop->checks, rci);
5712 loop->has_checks = true;
5713 gnu_cond = build_noreturn_cond (gnat_to_gnu (gnat_cond));
5714 if (flag_unswitch_loops)
5715 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
5716 boolean_type_node,
5717 rci->inserted_cond,
5718 gnu_cond);
5719 else
5720 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
5721 boolean_type_node,
5722 gnu_cond,
5723 rci->inserted_cond);
5726 /* Or else, if aggressive loop optimizations are enabled, we just
5727 record that there are checks applied to iteration variables. */
5728 else if (optimize
5729 && flag_aggressive_loop_optimizations
5730 && inside_loop_p ()
5731 && (loop = find_loop_for (gnu_index)))
5732 loop->has_checks = true;
5734 break;
5736 default:
5737 break;
5740 /* The following processing does the common work. */
5741 common:
5742 if (!gnu_result)
5743 gnu_result = build_call_raise (reason, gnat_node, kind);
5744 set_expr_location_from_node (gnu_result, gnat_node);
5746 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
5748 /* If the type is VOID, this is a statement, so we need to generate the code
5749 for the call. Handle a condition, if there is one. */
5750 if (VOID_TYPE_P (*gnu_result_type_p))
5752 if (Present (gnat_cond))
5754 if (!gnu_cond)
5755 gnu_cond = gnat_to_gnu (gnat_cond);
5756 gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
5757 alloc_stmt_list ());
5760 else
5761 gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
5763 return gnu_result;
5766 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
5767 parameter of a call. */
5769 static bool
5770 lhs_or_actual_p (Node_Id gnat_node)
5772 Node_Id gnat_parent = Parent (gnat_node);
5773 Node_Kind kind = Nkind (gnat_parent);
5775 if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
5776 return true;
5778 if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
5779 && Name (gnat_parent) != gnat_node)
5780 return true;
5782 if (kind == N_Parameter_Association)
5783 return true;
5785 return false;
5788 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
5789 of an assignment or an actual parameter of a call. */
5791 static bool
5792 present_in_lhs_or_actual_p (Node_Id gnat_node)
5794 Node_Kind kind;
5796 if (lhs_or_actual_p (gnat_node))
5797 return true;
5799 kind = Nkind (Parent (gnat_node));
5801 if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
5802 && lhs_or_actual_p (Parent (gnat_node)))
5803 return true;
5805 return false;
5808 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
5809 as gigi is concerned. This is used to avoid conversions on the LHS. */
5811 static bool
5812 unchecked_conversion_nop (Node_Id gnat_node)
5814 Entity_Id from_type, to_type;
5816 /* The conversion must be on the LHS of an assignment or an actual parameter
5817 of a call. Otherwise, even if the conversion was essentially a no-op, it
5818 could de facto ensure type consistency and this should be preserved. */
5819 if (!lhs_or_actual_p (gnat_node))
5820 return false;
5822 from_type = Etype (Expression (gnat_node));
5824 /* We're interested in artificial conversions generated by the front-end
5825 to make private types explicit, e.g. in Expand_Assign_Array. */
5826 if (!Is_Private_Type (from_type))
5827 return false;
5829 from_type = Underlying_Type (from_type);
5830 to_type = Etype (gnat_node);
5832 /* The direct conversion to the underlying type is a no-op. */
5833 if (to_type == from_type)
5834 return true;
5836 /* For an array subtype, the conversion to the PAIT is a no-op. */
5837 if (Ekind (from_type) == E_Array_Subtype
5838 && to_type == Packed_Array_Impl_Type (from_type))
5839 return true;
5841 /* For a record subtype, the conversion to the type is a no-op. */
5842 if (Ekind (from_type) == E_Record_Subtype
5843 && to_type == Etype (from_type))
5844 return true;
5846 return false;
5849 /* Return true if GNAT_NODE represents a statement. */
5851 static bool
5852 statement_node_p (Node_Id gnat_node)
5854 const Node_Kind kind = Nkind (gnat_node);
5856 if (kind == N_Label)
5857 return true;
5859 if (IN (kind, N_Statement_Other_Than_Procedure_Call))
5860 return true;
5862 if (kind == N_Procedure_Call_Statement)
5863 return true;
5865 if (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void)
5866 return true;
5868 return false;
5871 /* This function is the driver of the GNAT to GCC tree transformation process.
5872 It is the entry point of the tree transformer. GNAT_NODE is the root of
5873 some GNAT tree. Return the root of the corresponding GCC tree. If this
5874 is an expression, return the GCC equivalent of the expression. If this
5875 is a statement, return the statement or add it to the current statement
5876 group, in which case anything returned is to be interpreted as occurring
5877 after anything added. */
5879 tree
5880 gnat_to_gnu (Node_Id gnat_node)
5882 const Node_Kind kind = Nkind (gnat_node);
5883 bool went_into_elab_proc = false;
5884 tree gnu_result = error_mark_node; /* Default to no value. */
5885 tree gnu_result_type = void_type_node;
5886 tree gnu_expr, gnu_lhs, gnu_rhs;
5887 Node_Id gnat_temp;
5888 bool sync = false;
5890 /* Save node number for error message and set location information. */
5891 error_gnat_node = gnat_node;
5892 Sloc_to_locus (Sloc (gnat_node), &input_location);
5894 /* If we are only annotating types and this node is a statement, return
5895 an empty statement list. */
5896 if (type_annotate_only && statement_node_p (gnat_node))
5897 return alloc_stmt_list ();
5899 /* If we are only annotating types and this node is a subexpression, return
5900 a NULL_EXPR, but filter out nodes appearing in the expressions attached
5901 to packed array implementation types. */
5902 if (type_annotate_only
5903 && IN (kind, N_Subexpr)
5904 && !(((IN (kind, N_Op) && kind != N_Op_Expon)
5905 || kind == N_Type_Conversion)
5906 && Is_Integer_Type (Etype (gnat_node)))
5907 && !(kind == N_Attribute_Reference
5908 && Get_Attribute_Id (Attribute_Name (gnat_node)) == Attr_Length
5909 && Ekind (Etype (Prefix (gnat_node))) == E_Array_Subtype
5910 && !Is_Constr_Subt_For_U_Nominal (Etype (Prefix (gnat_node))))
5911 && kind != N_Expanded_Name
5912 && kind != N_Identifier
5913 && !Compile_Time_Known_Value (gnat_node))
5914 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
5915 build_call_raise (CE_Range_Check_Failed, gnat_node,
5916 N_Raise_Constraint_Error));
5918 if ((statement_node_p (gnat_node) && kind != N_Null_Statement)
5919 || kind == N_Handled_Sequence_Of_Statements
5920 || kind == N_Implicit_Label_Declaration)
5922 tree current_elab_proc = get_elaboration_procedure ();
5924 /* If this is a statement and we are at top level, it must be part of
5925 the elaboration procedure, so mark us as being in that procedure. */
5926 if (!current_function_decl)
5928 current_function_decl = current_elab_proc;
5929 went_into_elab_proc = true;
5932 /* If we are in the elaboration procedure, check if we are violating a
5933 No_Elaboration_Code restriction by having a statement there. Don't
5934 check for a possible No_Elaboration_Code restriction violation on
5935 N_Handled_Sequence_Of_Statements, as we want to signal an error on
5936 every nested real statement instead. This also avoids triggering
5937 spurious errors on dummy (empty) sequences created by the front-end
5938 for package bodies in some cases. */
5939 if (current_function_decl == current_elab_proc
5940 && kind != N_Handled_Sequence_Of_Statements
5941 && kind != N_Implicit_Label_Declaration)
5942 Check_Elaboration_Code_Allowed (gnat_node);
5945 switch (kind)
5947 /********************************/
5948 /* Chapter 2: Lexical Elements */
5949 /********************************/
5951 case N_Identifier:
5952 case N_Expanded_Name:
5953 case N_Operator_Symbol:
5954 case N_Defining_Identifier:
5955 case N_Defining_Operator_Symbol:
5956 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
5958 /* If atomic access is required on the RHS, build the atomic load. */
5959 if (atomic_access_required_p (gnat_node, &sync)
5960 && !present_in_lhs_or_actual_p (gnat_node))
5961 gnu_result = build_atomic_load (gnu_result, sync);
5962 break;
5964 case N_Integer_Literal:
5966 tree gnu_type;
5968 /* Get the type of the result, looking inside any padding and
5969 justified modular types. Then get the value in that type. */
5970 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
5972 if (TREE_CODE (gnu_type) == RECORD_TYPE
5973 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
5974 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
5976 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
5978 /* If the result overflows (meaning it doesn't fit in its base type),
5979 abort. We would like to check that the value is within the range
5980 of the subtype, but that causes problems with subtypes whose usage
5981 will raise Constraint_Error and with biased representation, so
5982 we don't. */
5983 gcc_assert (!TREE_OVERFLOW (gnu_result));
5985 break;
5987 case N_Character_Literal:
5988 /* If a Entity is present, it means that this was one of the
5989 literals in a user-defined character type. In that case,
5990 just return the value in the CONST_DECL. Otherwise, use the
5991 character code. In that case, the base type should be an
5992 INTEGER_TYPE, but we won't bother checking for that. */
5993 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5994 if (Present (Entity (gnat_node)))
5995 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
5996 else
5997 gnu_result
5998 = build_int_cst (gnu_result_type,
5999 UI_To_CC (Char_Literal_Value (gnat_node)));
6000 break;
6002 case N_Real_Literal:
6003 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6005 /* If this is of a fixed-point type, the value we want is the value of
6006 the corresponding integer. */
6007 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
6009 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
6010 gnu_result_type);
6011 gcc_assert (!TREE_OVERFLOW (gnu_result));
6014 else
6016 Ureal ur_realval = Realval (gnat_node);
6018 /* First convert the value to a machine number if it isn't already.
6019 That will force the base to 2 for non-zero values and simplify
6020 the rest of the logic. */
6021 if (!Is_Machine_Number (gnat_node))
6022 ur_realval
6023 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
6024 ur_realval, Round_Even, gnat_node);
6026 if (UR_Is_Zero (ur_realval))
6027 gnu_result = build_real (gnu_result_type, dconst0);
6028 else
6030 REAL_VALUE_TYPE tmp;
6032 gnu_result = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
6034 /* The base must be 2 as Machine guarantees this, so we scale
6035 the value, which we know can fit in the mantissa of the type
6036 (hence the use of that type above). */
6037 gcc_assert (Rbase (ur_realval) == 2);
6038 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
6039 - UI_To_Int (Denominator (ur_realval)));
6040 gnu_result = build_real (gnu_result_type, tmp);
6043 /* Now see if we need to negate the result. Do it this way to
6044 properly handle -0. */
6045 if (UR_Is_Negative (Realval (gnat_node)))
6046 gnu_result
6047 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
6048 gnu_result);
6051 break;
6053 case N_String_Literal:
6054 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6055 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
6057 String_Id gnat_string = Strval (gnat_node);
6058 int length = String_Length (gnat_string);
6059 int i;
6060 char *string;
6061 if (length >= ALLOCA_THRESHOLD)
6062 string = XNEWVEC (char, length + 1);
6063 else
6064 string = (char *) alloca (length + 1);
6066 /* Build the string with the characters in the literal. Note
6067 that Ada strings are 1-origin. */
6068 for (i = 0; i < length; i++)
6069 string[i] = Get_String_Char (gnat_string, i + 1);
6071 /* Put a null at the end of the string in case it's in a context
6072 where GCC will want to treat it as a C string. */
6073 string[i] = 0;
6075 gnu_result = build_string (length, string);
6077 /* Strings in GCC don't normally have types, but we want
6078 this to not be converted to the array type. */
6079 TREE_TYPE (gnu_result) = gnu_result_type;
6081 if (length >= ALLOCA_THRESHOLD)
6082 free (string);
6084 else
6086 /* Build a list consisting of each character, then make
6087 the aggregate. */
6088 String_Id gnat_string = Strval (gnat_node);
6089 int length = String_Length (gnat_string);
6090 int i;
6091 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6092 tree gnu_one_node = convert (TREE_TYPE (gnu_idx), integer_one_node);
6093 vec<constructor_elt, va_gc> *gnu_vec;
6094 vec_alloc (gnu_vec, length);
6096 for (i = 0; i < length; i++)
6098 tree t = build_int_cst (TREE_TYPE (gnu_result_type),
6099 Get_String_Char (gnat_string, i + 1));
6101 CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
6102 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, gnu_one_node);
6105 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
6107 break;
6109 case N_Pragma:
6110 gnu_result = Pragma_to_gnu (gnat_node);
6111 break;
6113 /**************************************/
6114 /* Chapter 3: Declarations and Types */
6115 /**************************************/
6117 case N_Subtype_Declaration:
6118 case N_Full_Type_Declaration:
6119 case N_Incomplete_Type_Declaration:
6120 case N_Private_Type_Declaration:
6121 case N_Private_Extension_Declaration:
6122 case N_Task_Type_Declaration:
6123 process_type (Defining_Entity (gnat_node));
6124 gnu_result = alloc_stmt_list ();
6125 break;
6127 case N_Object_Declaration:
6128 case N_Exception_Declaration:
6129 gnat_temp = Defining_Entity (gnat_node);
6130 gnu_result = alloc_stmt_list ();
6132 /* If we are just annotating types and this object has an unconstrained
6133 or task type, don't elaborate it. */
6134 if (type_annotate_only
6135 && (((Is_Array_Type (Etype (gnat_temp))
6136 || Is_Record_Type (Etype (gnat_temp)))
6137 && !Is_Constrained (Etype (gnat_temp)))
6138 || Is_Concurrent_Type (Etype (gnat_temp))))
6139 break;
6141 if (Present (Expression (gnat_node))
6142 && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
6143 && (!type_annotate_only
6144 || Compile_Time_Known_Value (Expression (gnat_node))))
6146 gnu_expr = gnat_to_gnu (Expression (gnat_node));
6147 if (Do_Range_Check (Expression (gnat_node)))
6148 gnu_expr
6149 = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
6151 if (type_annotate_only && TREE_CODE (gnu_expr) == ERROR_MARK)
6152 gnu_expr = NULL_TREE;
6154 else
6155 gnu_expr = NULL_TREE;
6157 /* If this is a deferred constant with an address clause, we ignore the
6158 full view since the clause is on the partial view and we cannot have
6159 2 different GCC trees for the object. The only bits of the full view
6160 we will use is the initializer, but it will be directly fetched. */
6161 if (Ekind (gnat_temp) == E_Constant
6162 && Present (Address_Clause (gnat_temp))
6163 && Present (Full_View (gnat_temp)))
6164 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
6166 /* If this object has its elaboration delayed, we must force evaluation
6167 of GNU_EXPR now and save it for the freeze point. Note that we need
6168 not do anything special at the global level since the lifetime of the
6169 temporary is fully contained within the elaboration routine. */
6170 if (Present (Freeze_Node (gnat_temp)))
6172 if (gnu_expr)
6174 gnu_result = gnat_save_expr (gnu_expr);
6175 save_gnu_tree (gnat_node, gnu_result, true);
6178 else
6179 gnat_to_gnu_entity (gnat_temp, gnu_expr, true);
6180 break;
6182 case N_Object_Renaming_Declaration:
6183 gnat_temp = Defining_Entity (gnat_node);
6184 gnu_result = alloc_stmt_list ();
6186 /* Don't do anything if this renaming is handled by the front end and it
6187 does not need debug info. Note that we consider renamings don't need
6188 debug info when optimizing: our way to describe them has a
6189 memory/elaboration footprint.
6191 Don't do anything neither if we are just annotating types and this
6192 object has a composite or task type, don't elaborate it. */
6193 if ((!Is_Renaming_Of_Object (gnat_temp)
6194 || (Needs_Debug_Info (gnat_temp)
6195 && !optimize
6196 && can_materialize_object_renaming_p
6197 (Renamed_Object (gnat_temp))))
6198 && ! (type_annotate_only
6199 && (Is_Array_Type (Etype (gnat_temp))
6200 || Is_Record_Type (Etype (gnat_temp))
6201 || Is_Concurrent_Type (Etype (gnat_temp)))))
6203 tree gnu_temp
6204 = gnat_to_gnu_entity (gnat_temp,
6205 gnat_to_gnu (Renamed_Object (gnat_temp)),
6206 true);
6207 /* See case 2 of renaming in gnat_to_gnu_entity. */
6208 if (TREE_SIDE_EFFECTS (gnu_temp))
6209 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
6211 break;
6213 case N_Exception_Renaming_Declaration:
6214 gnat_temp = Defining_Entity (gnat_node);
6215 gnu_result = alloc_stmt_list ();
6217 /* See the above case for the rationale. */
6218 if (Present (Renamed_Entity (gnat_temp)))
6220 tree gnu_temp
6221 = gnat_to_gnu_entity (gnat_temp,
6222 gnat_to_gnu (Renamed_Entity (gnat_temp)),
6223 true);
6224 if (TREE_SIDE_EFFECTS (gnu_temp))
6225 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
6227 break;
6229 case N_Subprogram_Renaming_Declaration:
6231 const Node_Id gnat_renaming = Defining_Entity (gnat_node);
6232 const Node_Id gnat_renamed = Renamed_Entity (gnat_renaming);
6234 gnu_result = alloc_stmt_list ();
6236 /* Materializing renamed subprograms will only benefit the debugging
6237 information as they aren't referenced in the generated code. So
6238 skip them when they aren't needed. Avoid doing this if:
6240 - there is a freeze node: in this case the renamed entity is not
6241 elaborated yet,
6242 - the renamed subprogram is intrinsic: it will not be available in
6243 the debugging information (note that both or only one of the
6244 renaming and the renamed subprograms can be intrinsic). */
6245 if (!type_annotate_only
6246 && Needs_Debug_Info (gnat_renaming)
6247 && No (Freeze_Node (gnat_renaming))
6248 && Present (gnat_renamed)
6249 && (Ekind (gnat_renamed) == E_Function
6250 || Ekind (gnat_renamed) == E_Procedure)
6251 && !Is_Intrinsic_Subprogram (gnat_renaming)
6252 && !Is_Intrinsic_Subprogram (gnat_renamed))
6253 gnat_to_gnu_entity (gnat_renaming, gnat_to_gnu (gnat_renamed), true);
6254 break;
6257 case N_Implicit_Label_Declaration:
6258 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
6259 gnu_result = alloc_stmt_list ();
6260 break;
6262 case N_Number_Declaration:
6263 case N_Package_Renaming_Declaration:
6264 /* These are fully handled in the front end. */
6265 /* ??? For package renamings, find a way to use GENERIC namespaces so
6266 that we get proper debug information for them. */
6267 gnu_result = alloc_stmt_list ();
6268 break;
6270 /*************************************/
6271 /* Chapter 4: Names and Expressions */
6272 /*************************************/
6274 case N_Explicit_Dereference:
6275 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6276 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6277 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
6279 /* If atomic access is required on the RHS, build the atomic load. */
6280 if (atomic_access_required_p (gnat_node, &sync)
6281 && !present_in_lhs_or_actual_p (gnat_node))
6282 gnu_result = build_atomic_load (gnu_result, sync);
6283 break;
6285 case N_Indexed_Component:
6287 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
6288 tree gnu_type;
6289 int ndim;
6290 int i;
6291 Node_Id *gnat_expr_array;
6293 gnu_array_object = maybe_implicit_deref (gnu_array_object);
6295 /* Convert vector inputs to their representative array type, to fit
6296 what the code below expects. */
6297 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object)))
6299 if (present_in_lhs_or_actual_p (gnat_node))
6300 gnat_mark_addressable (gnu_array_object);
6301 gnu_array_object = maybe_vector_array (gnu_array_object);
6304 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6306 /* If we got a padded type, remove it too. */
6307 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
6308 gnu_array_object
6309 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
6310 gnu_array_object);
6312 /* The failure of this assertion will very likely come from a missing
6313 expansion for a packed array access. */
6314 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
6316 /* First compute the number of dimensions of the array, then
6317 fill the expression array, the order depending on whether
6318 this is a Convention_Fortran array or not. */
6319 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
6320 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6321 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
6322 ndim++, gnu_type = TREE_TYPE (gnu_type))
6325 gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
6327 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
6328 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
6329 i >= 0;
6330 i--, gnat_temp = Next (gnat_temp))
6331 gnat_expr_array[i] = gnat_temp;
6332 else
6333 for (i = 0, gnat_temp = First (Expressions (gnat_node));
6334 i < ndim;
6335 i++, gnat_temp = Next (gnat_temp))
6336 gnat_expr_array[i] = gnat_temp;
6338 /* Start with the prefix and build the successive references. */
6339 gnu_result = gnu_array_object;
6341 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
6342 i < ndim;
6343 i++, gnu_type = TREE_TYPE (gnu_type))
6345 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
6346 gnat_temp = gnat_expr_array[i];
6347 gnu_expr = maybe_character_value (gnat_to_gnu (gnat_temp));
6348 struct loop_info_d *loop;
6350 gnu_result
6351 = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
6353 /* Array accesses are bound-checked so they cannot trap, but this
6354 is valid only if they are not hoisted ahead of the check. We
6355 need to mark them as no-trap to get decent loop optimizations
6356 in the presence of -fnon-call-exceptions, so we do it when we
6357 know that the original expression had no side-effects. */
6358 if (TREE_CODE (gnu_result) == ARRAY_REF
6359 && !(Nkind (gnat_temp) == N_Identifier
6360 && Ekind (Entity (gnat_temp)) == E_Constant))
6361 TREE_THIS_NOTRAP (gnu_result) = 1;
6363 /* If aggressive loop optimizations are enabled, we warn for loops
6364 overrunning a simple array of size 1 not at the end of a record.
6365 This is aimed to catch misuses of the trailing array idiom. */
6366 if (optimize
6367 && flag_aggressive_loop_optimizations
6368 && inside_loop_p ()
6369 && TREE_CODE (TREE_TYPE (gnu_type)) != ARRAY_TYPE
6370 && TREE_CODE (gnu_array_object) != ARRAY_REF
6371 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_type)),
6372 TYPE_MAX_VALUE (TYPE_DOMAIN (gnu_type)))
6373 && !array_at_struct_end_p (gnu_result)
6374 && (loop = find_loop_for (gnu_expr))
6375 && !loop->artificial
6376 && !loop->has_checks
6377 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_type)),
6378 loop->low_bound)
6379 && can_be_lower_p (loop->low_bound, loop->high_bound)
6380 && !loop->warned_aggressive_loop_optimizations
6381 && warning (OPT_Waggressive_loop_optimizations,
6382 "out-of-bounds access may be optimized away"))
6384 inform (EXPR_LOCATION (loop->stmt), "containing loop");
6385 loop->warned_aggressive_loop_optimizations = true;
6389 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6391 /* If atomic access is required on the RHS, build the atomic load. */
6392 if (atomic_access_required_p (gnat_node, &sync)
6393 && !present_in_lhs_or_actual_p (gnat_node))
6394 gnu_result = build_atomic_load (gnu_result, sync);
6396 break;
6398 case N_Slice:
6400 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
6402 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6404 gnu_array_object = maybe_implicit_deref (gnu_array_object);
6405 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6407 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6408 gnu_expr = maybe_character_value (gnu_expr);
6410 /* If this is a slice with non-constant size of an array with constant
6411 size, set the maximum size for the allocation of temporaries. */
6412 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
6413 && TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object))))
6414 TYPE_ARRAY_MAX_SIZE (gnu_result_type)
6415 = TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object));
6417 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
6418 gnu_array_object, gnu_expr);
6420 break;
6422 case N_Selected_Component:
6424 Entity_Id gnat_prefix = Prefix (gnat_node);
6425 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
6426 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
6428 gnu_prefix = maybe_implicit_deref (gnu_prefix);
6430 /* gnat_to_gnu_entity does not save the GNU tree made for renamed
6431 discriminants so avoid making recursive calls on each reference
6432 to them by following the appropriate link directly here. */
6433 if (Ekind (gnat_field) == E_Discriminant)
6435 /* For discriminant references in tagged types always substitute
6436 the corresponding discriminant as the actual component. */
6437 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix))))
6438 while (Present (Corresponding_Discriminant (gnat_field)))
6439 gnat_field = Corresponding_Discriminant (gnat_field);
6441 /* For discriminant references in untagged types always substitute
6442 the corresponding stored discriminant. */
6443 else if (Present (Corresponding_Discriminant (gnat_field)))
6444 gnat_field = Original_Record_Component (gnat_field);
6447 /* Handle extracting the real or imaginary part of a complex.
6448 The real part is the first field and the imaginary the last. */
6449 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
6450 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
6451 ? REALPART_EXPR : IMAGPART_EXPR,
6452 NULL_TREE, gnu_prefix);
6453 else
6455 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
6457 /* If the prefix has incomplete type, try again to translate it.
6458 The idea is that the translation of the field just above may
6459 have completed it through gnat_to_gnu_entity, in case it is
6460 the dereference of an access to Taft Amendment type used in
6461 the instantiation of a generic body from an external unit. */
6462 if (!COMPLETE_TYPE_P (TREE_TYPE (gnu_prefix)))
6464 gnu_prefix = gnat_to_gnu (gnat_prefix);
6465 gnu_prefix = maybe_implicit_deref (gnu_prefix);
6468 gnu_result
6469 = build_component_ref (gnu_prefix, gnu_field,
6470 (Nkind (Parent (gnat_node))
6471 == N_Attribute_Reference)
6472 && lvalue_required_for_attribute_p
6473 (Parent (gnat_node)));
6476 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6478 /* If atomic access is required on the RHS, build the atomic load. */
6479 if (atomic_access_required_p (gnat_node, &sync)
6480 && !present_in_lhs_or_actual_p (gnat_node))
6481 gnu_result = build_atomic_load (gnu_result, sync);
6483 break;
6485 case N_Attribute_Reference:
6487 /* The attribute designator. */
6488 const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
6490 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6491 is a unit, not an object with a GCC equivalent. */
6492 if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
6493 return
6494 create_subprog_decl (create_concat_name
6495 (Entity (Prefix (gnat_node)),
6496 attr == Attr_Elab_Body ? "elabb" : "elabs"),
6497 NULL_TREE, void_ftype, NULL_TREE, is_disabled,
6498 true, true, true, true, false, NULL,
6499 gnat_node);
6501 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
6503 break;
6505 case N_Reference:
6506 /* Like 'Access as far as we are concerned. */
6507 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6508 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6509 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6510 break;
6512 case N_Aggregate:
6513 case N_Extension_Aggregate:
6515 tree gnu_aggr_type;
6517 /* ??? It is wrong to evaluate the type now, but there doesn't
6518 seem to be any other practical way of doing it. */
6520 gcc_assert (!Expansion_Delayed (gnat_node));
6522 gnu_aggr_type = gnu_result_type
6523 = get_unpadded_type (Etype (gnat_node));
6525 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
6526 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
6527 gnu_aggr_type
6528 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type)));
6529 else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
6530 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
6532 if (Null_Record_Present (gnat_node))
6533 gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
6535 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
6536 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
6537 gnu_result
6538 = assoc_to_constructor (Etype (gnat_node),
6539 First (Component_Associations (gnat_node)),
6540 gnu_aggr_type);
6541 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
6542 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
6543 gnu_aggr_type,
6544 Component_Type (Etype (gnat_node)));
6545 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
6546 gnu_result
6547 = build_binary_op
6548 (COMPLEX_EXPR, gnu_aggr_type,
6549 gnat_to_gnu (Expression (First
6550 (Component_Associations (gnat_node)))),
6551 gnat_to_gnu (Expression
6552 (Next
6553 (First (Component_Associations (gnat_node))))));
6554 else
6555 gcc_unreachable ();
6557 gnu_result = convert (gnu_result_type, gnu_result);
6559 break;
6561 case N_Null:
6562 if (TARGET_VTABLE_USES_DESCRIPTORS
6563 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
6564 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
6565 gnu_result = null_fdesc_node;
6566 else
6567 gnu_result = null_pointer_node;
6568 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6569 break;
6571 case N_Type_Conversion:
6572 case N_Qualified_Expression:
6573 gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
6574 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6576 /* If this is a qualified expression for a tagged type, we mark the type
6577 as used. Because of polymorphism, this might be the only reference to
6578 the tagged type in the program while objects have it as dynamic type.
6579 The debugger needs to see it to display these objects properly. */
6580 if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
6581 used_types_insert (gnu_result_type);
6583 gnu_result
6584 = convert_with_check (Etype (gnat_node), gnu_expr,
6585 Do_Overflow_Check (gnat_node),
6586 Do_Range_Check (Expression (gnat_node)),
6587 kind == N_Type_Conversion
6588 && Float_Truncate (gnat_node), gnat_node);
6589 break;
6591 case N_Unchecked_Type_Conversion:
6592 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6593 gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
6595 /* Skip further processing if the conversion is deemed a no-op. */
6596 if (unchecked_conversion_nop (gnat_node))
6598 gnu_result = gnu_expr;
6599 gnu_result_type = TREE_TYPE (gnu_result);
6600 break;
6603 /* If the result is a pointer type, see if we are improperly
6604 converting to a stricter alignment. */
6605 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
6606 && IN (Ekind (Etype (gnat_node)), Access_Kind))
6608 unsigned int align = known_alignment (gnu_expr);
6609 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
6610 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
6612 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
6613 post_error_ne_tree_2
6614 ("?source alignment (^) '< alignment of & (^)",
6615 gnat_node, Designated_Type (Etype (gnat_node)),
6616 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
6619 /* If we are converting a descriptor to a function pointer, first
6620 build the pointer. */
6621 if (TARGET_VTABLE_USES_DESCRIPTORS
6622 && TREE_TYPE (gnu_expr) == fdesc_type_node
6623 && POINTER_TYPE_P (gnu_result_type))
6624 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
6626 gnu_result = unchecked_convert (gnu_result_type, gnu_expr,
6627 No_Truncation (gnat_node));
6628 break;
6630 case N_In:
6631 case N_Not_In:
6633 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
6634 tree gnu_low, gnu_high;
6636 Range_to_gnu (Right_Opnd (gnat_node), &gnu_low, &gnu_high);
6637 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6639 tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_obj));
6640 if (TREE_TYPE (gnu_obj) != gnu_op_type)
6642 gnu_obj = convert (gnu_op_type, gnu_obj);
6643 gnu_low = convert (gnu_op_type, gnu_low);
6644 gnu_high = convert (gnu_op_type, gnu_high);
6647 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
6648 ensure that GNU_OBJ is evaluated only once and perform a full range
6649 test. */
6650 if (operand_equal_p (gnu_low, gnu_high, 0))
6651 gnu_result
6652 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
6653 else
6655 tree t1, t2;
6656 gnu_obj = gnat_protect_expr (gnu_obj);
6657 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
6658 if (EXPR_P (t1))
6659 set_expr_location_from_node (t1, gnat_node);
6660 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
6661 if (EXPR_P (t2))
6662 set_expr_location_from_node (t2, gnat_node);
6663 gnu_result
6664 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
6667 if (kind == N_Not_In)
6668 gnu_result
6669 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
6671 break;
6673 case N_Op_Divide:
6674 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6675 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6676 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6677 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
6678 ? RDIV_EXPR
6679 : (Rounded_Result (gnat_node)
6680 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
6681 gnu_result_type, gnu_lhs, gnu_rhs);
6682 break;
6684 case N_Op_And:
6685 case N_Op_Or:
6686 case N_Op_Xor:
6687 /* These can either be operations on booleans or on modular types.
6688 Fall through for boolean types since that's the way GNU_CODES is
6689 set up. */
6690 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6692 enum tree_code code
6693 = (kind == N_Op_Or ? BIT_IOR_EXPR
6694 : kind == N_Op_And ? BIT_AND_EXPR
6695 : BIT_XOR_EXPR);
6697 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6698 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6699 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6700 gnu_result = build_binary_op (code, gnu_result_type,
6701 gnu_lhs, gnu_rhs);
6702 break;
6705 /* ... fall through ... */
6707 case N_Op_Eq:
6708 case N_Op_Ne:
6709 case N_Op_Lt:
6710 case N_Op_Le:
6711 case N_Op_Gt:
6712 case N_Op_Ge:
6713 case N_Op_Add:
6714 case N_Op_Subtract:
6715 case N_Op_Multiply:
6716 case N_Op_Mod:
6717 case N_Op_Rem:
6718 case N_Op_Rotate_Left:
6719 case N_Op_Rotate_Right:
6720 case N_Op_Shift_Left:
6721 case N_Op_Shift_Right:
6722 case N_Op_Shift_Right_Arithmetic:
6723 case N_And_Then:
6724 case N_Or_Else:
6726 enum tree_code code = gnu_codes[kind];
6727 bool ignore_lhs_overflow = false;
6728 location_t saved_location = input_location;
6729 tree gnu_type;
6731 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6732 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6733 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
6735 /* Pending generic support for efficient vector logical operations in
6736 GCC, convert vectors to their representative array type view and
6737 fallthrough. */
6738 gnu_lhs = maybe_vector_array (gnu_lhs);
6739 gnu_rhs = maybe_vector_array (gnu_rhs);
6741 /* If this is a comparison operator, convert any references to an
6742 unconstrained array value into a reference to the actual array. */
6743 if (TREE_CODE_CLASS (code) == tcc_comparison)
6745 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
6746 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
6748 tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_lhs));
6749 if (TREE_TYPE (gnu_lhs) != gnu_op_type)
6751 gnu_lhs = convert (gnu_op_type, gnu_lhs);
6752 gnu_rhs = convert (gnu_op_type, gnu_rhs);
6756 /* If this is a shift whose count is not guaranteed to be correct,
6757 we need to adjust the shift count. */
6758 if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
6760 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
6761 tree gnu_max_shift
6762 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
6764 if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
6765 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
6766 gnu_rhs, gnu_max_shift);
6767 else if (kind == N_Op_Shift_Right_Arithmetic)
6768 gnu_rhs
6769 = build_binary_op
6770 (MIN_EXPR, gnu_count_type,
6771 build_binary_op (MINUS_EXPR,
6772 gnu_count_type,
6773 gnu_max_shift,
6774 build_int_cst (gnu_count_type, 1)),
6775 gnu_rhs);
6778 /* For right shifts, the type says what kind of shift to do,
6779 so we may need to choose a different type. In this case,
6780 we have to ignore integer overflow lest it propagates all
6781 the way down and causes a CE to be explicitly raised. */
6782 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
6784 gnu_type = gnat_unsigned_type_for (gnu_type);
6785 ignore_lhs_overflow = true;
6787 else if (kind == N_Op_Shift_Right_Arithmetic
6788 && TYPE_UNSIGNED (gnu_type))
6790 gnu_type = gnat_signed_type_for (gnu_type);
6791 ignore_lhs_overflow = true;
6794 if (gnu_type != gnu_result_type)
6796 tree gnu_old_lhs = gnu_lhs;
6797 gnu_lhs = convert (gnu_type, gnu_lhs);
6798 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
6799 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
6800 gnu_rhs = convert (gnu_type, gnu_rhs);
6803 /* Instead of expanding overflow checks for addition, subtraction
6804 and multiplication itself, the front end will leave this to
6805 the back end when Backend_Overflow_Checks_On_Target is set. */
6806 if (Do_Overflow_Check (gnat_node)
6807 && Backend_Overflow_Checks_On_Target
6808 && (code == PLUS_EXPR || code == MINUS_EXPR || code == MULT_EXPR)
6809 && !TYPE_UNSIGNED (gnu_type)
6810 && !FLOAT_TYPE_P (gnu_type))
6811 gnu_result = build_binary_op_trapv (code, gnu_type,
6812 gnu_lhs, gnu_rhs, gnat_node);
6813 else
6815 /* Some operations, e.g. comparisons of arrays, generate complex
6816 trees that need to be annotated while they are being built. */
6817 input_location = saved_location;
6818 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
6821 /* If this is a logical shift with the shift count not verified,
6822 we must return zero if it is too large. We cannot compensate
6823 above in this case. */
6824 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
6825 && !Shift_Count_OK (gnat_node))
6826 gnu_result
6827 = build_cond_expr
6828 (gnu_type,
6829 build_binary_op (GE_EXPR, boolean_type_node,
6830 gnu_rhs,
6831 convert (TREE_TYPE (gnu_rhs),
6832 TYPE_SIZE (gnu_type))),
6833 build_int_cst (gnu_type, 0),
6834 gnu_result);
6836 break;
6838 case N_If_Expression:
6840 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
6841 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
6842 tree gnu_false
6843 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
6845 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6846 gnu_result
6847 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
6849 break;
6851 case N_Op_Plus:
6852 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
6853 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6854 break;
6856 case N_Op_Not:
6857 /* This case can apply to a boolean or a modular type.
6858 Fall through for a boolean operand since GNU_CODES is set
6859 up to handle this. */
6860 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6862 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
6863 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6864 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
6865 gnu_expr);
6866 break;
6869 /* ... fall through ... */
6871 case N_Op_Minus:
6872 case N_Op_Abs:
6873 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
6874 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6876 /* Instead of expanding overflow checks for negation and absolute
6877 value itself, the front end will leave this to the back end
6878 when Backend_Overflow_Checks_On_Target is set. */
6879 if (Do_Overflow_Check (gnat_node)
6880 && Backend_Overflow_Checks_On_Target
6881 && !TYPE_UNSIGNED (gnu_result_type)
6882 && !FLOAT_TYPE_P (gnu_result_type))
6883 gnu_result
6884 = build_unary_op_trapv (gnu_codes[kind],
6885 gnu_result_type, gnu_expr, gnat_node);
6886 else
6887 gnu_result = build_unary_op (gnu_codes[kind],
6888 gnu_result_type, gnu_expr);
6889 break;
6891 case N_Allocator:
6893 tree gnu_init = NULL_TREE;
6894 tree gnu_type;
6895 bool ignore_init_type = false;
6897 gnat_temp = Expression (gnat_node);
6899 /* The Expression operand can either be an N_Identifier or
6900 Expanded_Name, which must represent a type, or a
6901 N_Qualified_Expression, which contains both the object type and an
6902 initial value for the object. */
6903 if (Nkind (gnat_temp) == N_Identifier
6904 || Nkind (gnat_temp) == N_Expanded_Name)
6905 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
6906 else if (Nkind (gnat_temp) == N_Qualified_Expression)
6908 Entity_Id gnat_desig_type
6909 = Designated_Type (Underlying_Type (Etype (gnat_node)));
6911 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
6912 gnu_init = gnat_to_gnu (Expression (gnat_temp));
6914 gnu_init = maybe_unconstrained_array (gnu_init);
6915 if (Do_Range_Check (Expression (gnat_temp)))
6916 gnu_init
6917 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
6919 if (Is_Elementary_Type (gnat_desig_type)
6920 || Is_Constrained (gnat_desig_type))
6921 gnu_type = gnat_to_gnu_type (gnat_desig_type);
6922 else
6924 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
6925 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
6926 gnu_type = TREE_TYPE (gnu_init);
6929 /* See the N_Qualified_Expression case for the rationale. */
6930 if (Is_Tagged_Type (gnat_desig_type))
6931 used_types_insert (gnu_type);
6933 gnu_init = convert (gnu_type, gnu_init);
6935 else
6936 gcc_unreachable ();
6938 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6939 return build_allocator (gnu_type, gnu_init, gnu_result_type,
6940 Procedure_To_Call (gnat_node),
6941 Storage_Pool (gnat_node), gnat_node,
6942 ignore_init_type);
6944 break;
6946 /**************************/
6947 /* Chapter 5: Statements */
6948 /**************************/
6950 case N_Label:
6951 gnu_result = build1 (LABEL_EXPR, void_type_node,
6952 gnat_to_gnu (Identifier (gnat_node)));
6953 break;
6955 case N_Null_Statement:
6956 /* When not optimizing, turn null statements from source into gotos to
6957 the next statement that the middle-end knows how to preserve. */
6958 if (!optimize && Comes_From_Source (gnat_node))
6960 tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
6961 DECL_IGNORED_P (label) = 1;
6962 start_stmt_group ();
6963 stmt = build1 (GOTO_EXPR, void_type_node, label);
6964 set_expr_location_from_node (stmt, gnat_node);
6965 add_stmt (stmt);
6966 stmt = build1 (LABEL_EXPR, void_type_node, label);
6967 set_expr_location_from_node (stmt, gnat_node);
6968 add_stmt (stmt);
6969 gnu_result = end_stmt_group ();
6971 else
6972 gnu_result = alloc_stmt_list ();
6973 break;
6975 case N_Assignment_Statement:
6976 /* Get the LHS and RHS of the statement and convert any reference to an
6977 unconstrained array into a reference to the underlying array. */
6978 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
6980 /* If the type has a size that overflows, convert this into raise of
6981 Storage_Error: execution shouldn't have gotten here anyway. */
6982 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
6983 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
6984 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
6985 N_Raise_Storage_Error);
6986 else if (Nkind (Expression (gnat_node)) == N_Function_Call)
6988 bool outer_atomic_access
6989 = outer_atomic_access_required_p (Name (gnat_node));
6990 bool atomic_access
6991 = !outer_atomic_access
6992 && atomic_access_required_p (Name (gnat_node), &sync);
6993 gnu_result
6994 = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
6995 outer_atomic_access, atomic_access, sync);
6997 else
6999 const Node_Id gnat_expr = Expression (gnat_node);
7000 const Entity_Id gnat_type
7001 = Underlying_Type (Etype (Name (gnat_node)));
7002 const bool regular_array_type_p
7003 = (Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type));
7004 const bool use_memset_p
7005 = (regular_array_type_p
7006 && Nkind (gnat_expr) == N_Aggregate
7007 && Is_Others_Aggregate (gnat_expr));
7009 /* If we'll use memset, we need to find the inner expression. */
7010 if (use_memset_p)
7012 Node_Id gnat_inner
7013 = Expression (First (Component_Associations (gnat_expr)));
7014 while (Nkind (gnat_inner) == N_Aggregate
7015 && Is_Others_Aggregate (gnat_inner))
7016 gnat_inner
7017 = Expression (First (Component_Associations (gnat_inner)));
7018 gnu_rhs = gnat_to_gnu (gnat_inner);
7020 else
7021 gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
7023 /* If range check is needed, emit code to generate it. */
7024 if (Do_Range_Check (gnat_expr))
7025 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
7026 gnat_node);
7028 /* If an outer atomic access is required on the LHS, build the load-
7029 modify-store sequence. */
7030 if (outer_atomic_access_required_p (Name (gnat_node)))
7031 gnu_result = build_load_modify_store (gnu_lhs, gnu_rhs, gnat_node);
7033 /* Or else, if atomic access is required, build the atomic store. */
7034 else if (atomic_access_required_p (Name (gnat_node), &sync))
7035 gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, sync);
7037 /* Or else, use memset when the conditions are met. */
7038 else if (use_memset_p)
7040 tree value = fold_convert (integer_type_node, gnu_rhs);
7041 tree to = gnu_lhs;
7042 tree type = TREE_TYPE (to);
7043 tree size
7044 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), to);
7045 tree to_ptr = build_fold_addr_expr (to);
7046 tree t = builtin_decl_explicit (BUILT_IN_MEMSET);
7047 if (TREE_CODE (value) == INTEGER_CST)
7049 tree mask
7050 = build_int_cst (integer_type_node,
7051 ((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1);
7052 value = int_const_binop (BIT_AND_EXPR, value, mask);
7054 gnu_result = build_call_expr (t, 3, to_ptr, value, size);
7057 /* Otherwise build a regular assignment. */
7058 else
7059 gnu_result
7060 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
7062 /* If the assignment type is a regular array and the two sides are
7063 not completely disjoint, play safe and use memmove. But don't do
7064 it for a bit-packed array as it might not be byte-aligned. */
7065 if (TREE_CODE (gnu_result) == MODIFY_EXPR
7066 && regular_array_type_p
7067 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
7069 tree to = TREE_OPERAND (gnu_result, 0);
7070 tree from = TREE_OPERAND (gnu_result, 1);
7071 tree type = TREE_TYPE (from);
7072 tree size
7073 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from);
7074 tree to_ptr = build_fold_addr_expr (to);
7075 tree from_ptr = build_fold_addr_expr (from);
7076 tree t = builtin_decl_explicit (BUILT_IN_MEMMOVE);
7077 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
7080 break;
7082 case N_If_Statement:
7084 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
7086 /* Make the outer COND_EXPR. Avoid non-determinism. */
7087 gnu_result = build3 (COND_EXPR, void_type_node,
7088 gnat_to_gnu (Condition (gnat_node)),
7089 NULL_TREE, NULL_TREE);
7090 COND_EXPR_THEN (gnu_result)
7091 = build_stmt_group (Then_Statements (gnat_node), false);
7092 TREE_SIDE_EFFECTS (gnu_result) = 1;
7093 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
7095 /* Now make a COND_EXPR for each of the "else if" parts. Put each
7096 into the previous "else" part and point to where to put any
7097 outer "else". Also avoid non-determinism. */
7098 if (Present (Elsif_Parts (gnat_node)))
7099 for (gnat_temp = First (Elsif_Parts (gnat_node));
7100 Present (gnat_temp); gnat_temp = Next (gnat_temp))
7102 gnu_expr = build3 (COND_EXPR, void_type_node,
7103 gnat_to_gnu (Condition (gnat_temp)),
7104 NULL_TREE, NULL_TREE);
7105 COND_EXPR_THEN (gnu_expr)
7106 = build_stmt_group (Then_Statements (gnat_temp), false);
7107 TREE_SIDE_EFFECTS (gnu_expr) = 1;
7108 set_expr_location_from_node (gnu_expr, gnat_temp);
7109 *gnu_else_ptr = gnu_expr;
7110 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
7113 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
7115 break;
7117 case N_Case_Statement:
7118 gnu_result = Case_Statement_to_gnu (gnat_node);
7119 break;
7121 case N_Loop_Statement:
7122 gnu_result = Loop_Statement_to_gnu (gnat_node);
7123 break;
7125 case N_Block_Statement:
7126 /* The only way to enter the block is to fall through to it. */
7127 if (stmt_group_may_fallthru ())
7129 start_stmt_group ();
7130 gnat_pushlevel ();
7131 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7132 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7133 gnat_poplevel ();
7134 gnu_result = end_stmt_group ();
7136 else
7137 gnu_result = alloc_stmt_list ();
7138 break;
7140 case N_Exit_Statement:
7141 gnu_result
7142 = build2 (EXIT_STMT, void_type_node,
7143 (Present (Condition (gnat_node))
7144 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
7145 (Present (Name (gnat_node))
7146 ? get_gnu_tree (Entity (Name (gnat_node)))
7147 : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt)));
7148 break;
7150 case N_Simple_Return_Statement:
7152 tree gnu_ret_obj, gnu_ret_val;
7154 /* If the subprogram is a function, we must return the expression. */
7155 if (Present (Expression (gnat_node)))
7157 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
7159 /* If this function has copy-in/copy-out parameters parameters and
7160 doesn't return by invisible reference, get the real object for
7161 the return. See Subprogram_Body_to_gnu. */
7162 if (TYPE_CI_CO_LIST (gnu_subprog_type)
7163 && !TREE_ADDRESSABLE (gnu_subprog_type))
7164 gnu_ret_obj = gnu_return_var_stack->last ();
7165 else
7166 gnu_ret_obj = DECL_RESULT (current_function_decl);
7168 /* Get the GCC tree for the expression to be returned. */
7169 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
7171 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7172 self-referential since we want to allocate the fixed size. */
7173 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
7174 && type_is_padding_self_referential
7175 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
7176 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
7178 /* If the function returns by direct reference, return a pointer
7179 to the return value. */
7180 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
7181 || By_Ref (gnat_node))
7182 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
7184 /* Otherwise, if it returns an unconstrained array, we have to
7185 allocate a new version of the result and return it. */
7186 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
7188 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
7190 /* And find out whether this is a candidate for Named Return
7191 Value. If so, record it. */
7192 if (!TYPE_CI_CO_LIST (gnu_subprog_type) && optimize)
7194 tree ret_val = gnu_ret_val;
7196 /* Strip useless conversions around the return value. */
7197 if (gnat_useless_type_conversion (ret_val))
7198 ret_val = TREE_OPERAND (ret_val, 0);
7200 /* Strip unpadding around the return value. */
7201 if (TREE_CODE (ret_val) == COMPONENT_REF
7202 && TYPE_IS_PADDING_P
7203 (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
7204 ret_val = TREE_OPERAND (ret_val, 0);
7206 /* Now apply the test to the return value. */
7207 if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
7209 if (!f_named_ret_val)
7210 f_named_ret_val = BITMAP_GGC_ALLOC ();
7211 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
7212 if (!f_gnat_ret)
7213 f_gnat_ret = gnat_node;
7217 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
7218 gnu_ret_val,
7219 TREE_TYPE (gnu_ret_obj),
7220 Procedure_To_Call (gnat_node),
7221 Storage_Pool (gnat_node),
7222 gnat_node, false);
7225 /* Otherwise, if it returns by invisible reference, dereference
7226 the pointer it is passed using the type of the return value
7227 and build the copy operation manually. This ensures that we
7228 don't copy too much data, for example if the return type is
7229 unconstrained with a maximum size. */
7230 else if (TREE_ADDRESSABLE (gnu_subprog_type))
7232 tree gnu_ret_deref
7233 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
7234 gnu_ret_obj);
7235 gnu_result = build2 (INIT_EXPR, void_type_node,
7236 gnu_ret_deref, gnu_ret_val);
7237 add_stmt_with_node (gnu_result, gnat_node);
7238 gnu_ret_val = NULL_TREE;
7242 else
7243 gnu_ret_obj = gnu_ret_val = NULL_TREE;
7245 /* If we have a return label defined, convert this into a branch to
7246 that label. The return proper will be handled elsewhere. */
7247 if (gnu_return_label_stack->last ())
7249 if (gnu_ret_val)
7250 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
7251 gnu_ret_val));
7253 gnu_result = build1 (GOTO_EXPR, void_type_node,
7254 gnu_return_label_stack->last ());
7256 /* When not optimizing, make sure the return is preserved. */
7257 if (!optimize && Comes_From_Source (gnat_node))
7258 DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0;
7261 /* Otherwise, build a regular return. */
7262 else
7263 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
7265 break;
7267 case N_Goto_Statement:
7268 gnu_result
7269 = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node)));
7270 break;
7272 /***************************/
7273 /* Chapter 6: Subprograms */
7274 /***************************/
7276 case N_Subprogram_Declaration:
7277 /* Unless there is a freeze node, declare the entity. We consider
7278 this a definition even though we're not generating code for the
7279 subprogram because we will be making the corresponding GCC node.
7280 When there is a freeze node, it is considered the definition of
7281 the subprogram and we do nothing until after it is encountered.
7282 That's an efficiency issue: the types involved in the profile
7283 are far more likely to be frozen between the declaration and
7284 the freeze node than before the declaration, so we save some
7285 updates of the GCC node by waiting until the freeze node.
7286 The counterpart is that we assume that there is no reference
7287 to the subprogram between the declaration and the freeze node
7288 in the expanded code; otherwise, it will be interpreted as an
7289 external reference and very likely give rise to a link failure. */
7290 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7291 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
7292 NULL_TREE, true);
7293 gnu_result = alloc_stmt_list ();
7294 break;
7296 case N_Abstract_Subprogram_Declaration:
7297 /* This subprogram doesn't exist for code generation purposes, but we
7298 have to elaborate the types of any parameters and result, unless
7299 they are imported types (nothing to generate in this case).
7301 The parameter list may contain types with freeze nodes, e.g. not null
7302 subtypes, so the subprogram itself may carry a freeze node, in which
7303 case its elaboration must be deferred. */
7305 /* Process the parameter types first. */
7306 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7307 for (gnat_temp
7308 = First_Formal_With_Extras
7309 (Defining_Entity (Specification (gnat_node)));
7310 Present (gnat_temp);
7311 gnat_temp = Next_Formal_With_Extras (gnat_temp))
7312 if (Is_Itype (Etype (gnat_temp))
7313 && !From_Limited_With (Etype (gnat_temp)))
7314 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
7316 /* Then the result type, set to Standard_Void_Type for procedures. */
7318 Entity_Id gnat_temp_type
7319 = Etype (Defining_Entity (Specification (gnat_node)));
7321 if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type))
7322 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, false);
7325 gnu_result = alloc_stmt_list ();
7326 break;
7328 case N_Defining_Program_Unit_Name:
7329 /* For a child unit identifier go up a level to get the specification.
7330 We get this when we try to find the spec of a child unit package
7331 that is the compilation unit being compiled. */
7332 gnu_result = gnat_to_gnu (Parent (gnat_node));
7333 break;
7335 case N_Subprogram_Body:
7336 Subprogram_Body_to_gnu (gnat_node);
7337 gnu_result = alloc_stmt_list ();
7338 break;
7340 case N_Function_Call:
7341 case N_Procedure_Call_Statement:
7342 gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
7343 false, false, false);
7344 break;
7346 /************************/
7347 /* Chapter 7: Packages */
7348 /************************/
7350 case N_Package_Declaration:
7351 gnu_result = gnat_to_gnu (Specification (gnat_node));
7352 break;
7354 case N_Package_Specification:
7356 start_stmt_group ();
7357 process_decls (Visible_Declarations (gnat_node),
7358 Private_Declarations (gnat_node), Empty, true, true);
7359 gnu_result = end_stmt_group ();
7360 break;
7362 case N_Package_Body:
7364 /* If this is the body of a generic package - do nothing. */
7365 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
7367 gnu_result = alloc_stmt_list ();
7368 break;
7371 start_stmt_group ();
7372 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7374 if (Present (Handled_Statement_Sequence (gnat_node)))
7375 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7377 gnu_result = end_stmt_group ();
7378 break;
7380 /********************************/
7381 /* Chapter 8: Visibility Rules */
7382 /********************************/
7384 case N_Use_Package_Clause:
7385 case N_Use_Type_Clause:
7386 /* Nothing to do here - but these may appear in list of declarations. */
7387 gnu_result = alloc_stmt_list ();
7388 break;
7390 /*********************/
7391 /* Chapter 9: Tasks */
7392 /*********************/
7394 case N_Protected_Type_Declaration:
7395 gnu_result = alloc_stmt_list ();
7396 break;
7398 case N_Single_Task_Declaration:
7399 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
7400 gnu_result = alloc_stmt_list ();
7401 break;
7403 /*********************************************************/
7404 /* Chapter 10: Program Structure and Compilation Issues */
7405 /*********************************************************/
7407 case N_Compilation_Unit:
7408 /* This is not called for the main unit on which gigi is invoked. */
7409 Compilation_Unit_to_gnu (gnat_node);
7410 gnu_result = alloc_stmt_list ();
7411 break;
7413 case N_Subunit:
7414 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
7415 break;
7417 case N_Entry_Body:
7418 case N_Protected_Body:
7419 case N_Task_Body:
7420 /* These nodes should only be present when annotating types. */
7421 gcc_assert (type_annotate_only);
7422 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7423 gnu_result = alloc_stmt_list ();
7424 break;
7426 case N_Subprogram_Body_Stub:
7427 case N_Package_Body_Stub:
7428 case N_Protected_Body_Stub:
7429 case N_Task_Body_Stub:
7430 /* Simply process whatever unit is being inserted. */
7431 if (Present (Library_Unit (gnat_node)))
7432 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
7433 else
7435 gcc_assert (type_annotate_only);
7436 gnu_result = alloc_stmt_list ();
7438 break;
7440 /***************************/
7441 /* Chapter 11: Exceptions */
7442 /***************************/
7444 case N_Handled_Sequence_Of_Statements:
7445 /* If there is an At_End procedure attached to this node, and the EH
7446 mechanism is front-end, we must have at least a corresponding At_End
7447 handler, unless the No_Exception_Handlers restriction is set. */
7448 gcc_assert (type_annotate_only
7449 || !Front_End_Exceptions ()
7450 || No (At_End_Proc (gnat_node))
7451 || Present (Exception_Handlers (gnat_node))
7452 || No_Exception_Handlers_Set ());
7454 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
7455 break;
7457 case N_Exception_Handler:
7458 if (Exception_Mechanism == Front_End_SJLJ)
7459 gnu_result = Exception_Handler_to_gnu_fe_sjlj (gnat_node);
7460 else if (Back_End_Exceptions ())
7461 gnu_result = Exception_Handler_to_gnu_gcc (gnat_node);
7462 else
7463 gcc_unreachable ();
7464 break;
7466 case N_Raise_Statement:
7467 /* Only for reraise in back-end exceptions mode. */
7468 gcc_assert (No (Name (gnat_node))
7469 && Back_End_Exceptions ());
7471 start_stmt_group ();
7472 gnat_pushlevel ();
7474 /* Clear the current exception pointer so that the occurrence won't be
7475 deallocated. */
7476 gnu_expr = create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE,
7477 ptr_type_node, gnu_incoming_exc_ptr,
7478 false, false, false, false, false,
7479 true, true, NULL, gnat_node);
7481 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr,
7482 build_int_cst (ptr_type_node, 0)));
7483 add_stmt (build_call_n_expr (reraise_zcx_decl, 1, gnu_expr));
7484 gnat_poplevel ();
7485 gnu_result = end_stmt_group ();
7486 break;
7488 case N_Push_Constraint_Error_Label:
7489 push_exception_label_stack (&gnu_constraint_error_label_stack,
7490 Exception_Label (gnat_node));
7491 break;
7493 case N_Push_Storage_Error_Label:
7494 push_exception_label_stack (&gnu_storage_error_label_stack,
7495 Exception_Label (gnat_node));
7496 break;
7498 case N_Push_Program_Error_Label:
7499 push_exception_label_stack (&gnu_program_error_label_stack,
7500 Exception_Label (gnat_node));
7501 break;
7503 case N_Pop_Constraint_Error_Label:
7504 gnu_constraint_error_label_stack->pop ();
7505 break;
7507 case N_Pop_Storage_Error_Label:
7508 gnu_storage_error_label_stack->pop ();
7509 break;
7511 case N_Pop_Program_Error_Label:
7512 gnu_program_error_label_stack->pop ();
7513 break;
7515 /******************************/
7516 /* Chapter 12: Generic Units */
7517 /******************************/
7519 case N_Generic_Function_Renaming_Declaration:
7520 case N_Generic_Package_Renaming_Declaration:
7521 case N_Generic_Procedure_Renaming_Declaration:
7522 case N_Generic_Package_Declaration:
7523 case N_Generic_Subprogram_Declaration:
7524 case N_Package_Instantiation:
7525 case N_Procedure_Instantiation:
7526 case N_Function_Instantiation:
7527 /* These nodes can appear on a declaration list but there is nothing to
7528 to be done with them. */
7529 gnu_result = alloc_stmt_list ();
7530 break;
7532 /**************************************************/
7533 /* Chapter 13: Representation Clauses and */
7534 /* Implementation-Dependent Features */
7535 /**************************************************/
7537 case N_Attribute_Definition_Clause:
7538 gnu_result = alloc_stmt_list ();
7540 /* The only one we need to deal with is 'Address since, for the others,
7541 the front-end puts the information elsewhere. */
7542 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
7543 break;
7545 /* And we only deal with 'Address if the object has a Freeze node. */
7546 gnat_temp = Entity (Name (gnat_node));
7547 if (No (Freeze_Node (gnat_temp)))
7548 break;
7550 /* Get the value to use as the address and save it as the equivalent
7551 for the object. When it is frozen, gnat_to_gnu_entity will do the
7552 right thing. */
7553 save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
7554 break;
7556 case N_Enumeration_Representation_Clause:
7557 case N_Record_Representation_Clause:
7558 case N_At_Clause:
7559 /* We do nothing with these. SEM puts the information elsewhere. */
7560 gnu_result = alloc_stmt_list ();
7561 break;
7563 case N_Code_Statement:
7564 if (!type_annotate_only)
7566 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
7567 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
7568 tree gnu_clobbers = NULL_TREE, tail;
7569 bool allows_mem, allows_reg, fake;
7570 int ninputs, noutputs, i;
7571 const char **oconstraints;
7572 const char *constraint;
7573 char *clobber;
7575 /* First retrieve the 3 operand lists built by the front-end. */
7576 Setup_Asm_Outputs (gnat_node);
7577 while (Present (gnat_temp = Asm_Output_Variable ()))
7579 tree gnu_value = gnat_to_gnu (gnat_temp);
7580 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7581 (Asm_Output_Constraint ()));
7583 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
7584 Next_Asm_Output ();
7587 Setup_Asm_Inputs (gnat_node);
7588 while (Present (gnat_temp = Asm_Input_Value ()))
7590 tree gnu_value = gnat_to_gnu (gnat_temp);
7591 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7592 (Asm_Input_Constraint ()));
7594 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
7595 Next_Asm_Input ();
7598 Clobber_Setup (gnat_node);
7599 while ((clobber = Clobber_Get_Next ()))
7600 gnu_clobbers
7601 = tree_cons (NULL_TREE,
7602 build_string (strlen (clobber) + 1, clobber),
7603 gnu_clobbers);
7605 /* Then perform some standard checking and processing on the
7606 operands. In particular, mark them addressable if needed. */
7607 gnu_outputs = nreverse (gnu_outputs);
7608 noutputs = list_length (gnu_outputs);
7609 gnu_inputs = nreverse (gnu_inputs);
7610 ninputs = list_length (gnu_inputs);
7611 oconstraints = XALLOCAVEC (const char *, noutputs);
7613 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
7615 tree output = TREE_VALUE (tail);
7616 constraint
7617 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7618 oconstraints[i] = constraint;
7620 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
7621 &allows_mem, &allows_reg, &fake))
7623 /* If the operand is going to end up in memory,
7624 mark it addressable. Note that we don't test
7625 allows_mem like in the input case below; this
7626 is modelled on the C front-end. */
7627 if (!allows_reg)
7629 output = remove_conversions (output, false);
7630 if (TREE_CODE (output) == CONST_DECL
7631 && DECL_CONST_CORRESPONDING_VAR (output))
7632 output = DECL_CONST_CORRESPONDING_VAR (output);
7633 if (!gnat_mark_addressable (output))
7634 output = error_mark_node;
7637 else
7638 output = error_mark_node;
7640 TREE_VALUE (tail) = output;
7643 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
7645 tree input = TREE_VALUE (tail);
7646 constraint
7647 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7649 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
7650 0, oconstraints,
7651 &allows_mem, &allows_reg))
7653 /* If the operand is going to end up in memory,
7654 mark it addressable. */
7655 if (!allows_reg && allows_mem)
7657 input = remove_conversions (input, false);
7658 if (TREE_CODE (input) == CONST_DECL
7659 && DECL_CONST_CORRESPONDING_VAR (input))
7660 input = DECL_CONST_CORRESPONDING_VAR (input);
7661 if (!gnat_mark_addressable (input))
7662 input = error_mark_node;
7665 else
7666 input = error_mark_node;
7668 TREE_VALUE (tail) = input;
7671 gnu_result = build5 (ASM_EXPR, void_type_node,
7672 gnu_template, gnu_outputs,
7673 gnu_inputs, gnu_clobbers, NULL_TREE);
7674 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
7676 else
7677 gnu_result = alloc_stmt_list ();
7679 break;
7681 /****************/
7682 /* Added Nodes */
7683 /****************/
7685 case N_Expression_With_Actions:
7686 /* This construct doesn't define a scope so we don't push a binding
7687 level around the statement list, but we wrap it in a SAVE_EXPR to
7688 protect it from unsharing. Elaborate the expression as part of the
7689 same statement group as the actions so that the type declaration
7690 gets inserted there as well. This ensures that the type elaboration
7691 code is issued past the actions computing values on which it might
7692 depend. */
7693 start_stmt_group ();
7694 add_stmt_list (Actions (gnat_node));
7695 gnu_expr = gnat_to_gnu (Expression (gnat_node));
7696 gnu_result = end_stmt_group ();
7698 gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
7699 TREE_SIDE_EFFECTS (gnu_result) = 1;
7701 gnu_result
7702 = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
7703 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7704 break;
7706 case N_Freeze_Entity:
7707 start_stmt_group ();
7708 process_freeze_entity (gnat_node);
7709 process_decls (Actions (gnat_node), Empty, Empty, true, true);
7710 gnu_result = end_stmt_group ();
7711 break;
7713 case N_Freeze_Generic_Entity:
7714 gnu_result = alloc_stmt_list ();
7715 break;
7717 case N_Itype_Reference:
7718 if (!present_gnu_tree (Itype (gnat_node)))
7719 process_type (Itype (gnat_node));
7720 gnu_result = alloc_stmt_list ();
7721 break;
7723 case N_Free_Statement:
7724 if (!type_annotate_only)
7726 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
7727 tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
7728 tree gnu_obj_type, gnu_actual_obj_type;
7730 /* If this is a thin pointer, we must first dereference it to create
7731 a fat pointer, then go back below to a thin pointer. The reason
7732 for this is that we need to have a fat pointer someplace in order
7733 to properly compute the size. */
7734 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
7735 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
7736 build_unary_op (INDIRECT_REF, NULL_TREE,
7737 gnu_ptr));
7739 /* If this is a fat pointer, the object must have been allocated with
7740 the template in front of the array. So pass the template address,
7741 and get the total size; do it by converting to a thin pointer. */
7742 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
7743 gnu_ptr
7744 = convert (build_pointer_type
7745 (TYPE_OBJECT_RECORD_TYPE
7746 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
7747 gnu_ptr);
7749 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
7751 /* If this is a thin pointer, the object must have been allocated with
7752 the template in front of the array. So pass the template address,
7753 and get the total size. */
7754 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
7755 gnu_ptr
7756 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
7757 gnu_ptr,
7758 fold_build1 (NEGATE_EXPR, sizetype,
7759 byte_position
7760 (DECL_CHAIN
7761 TYPE_FIELDS ((gnu_obj_type)))));
7763 /* If we have a special dynamic constrained subtype on the node, use
7764 it to compute the size; otherwise, use the designated subtype. */
7765 if (Present (Actual_Designated_Subtype (gnat_node)))
7767 gnu_actual_obj_type
7768 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
7770 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
7771 gnu_actual_obj_type
7772 = build_unc_object_type_from_ptr (gnu_ptr_type,
7773 gnu_actual_obj_type,
7774 get_identifier ("DEALLOC"),
7775 false);
7777 else
7778 gnu_actual_obj_type = gnu_obj_type;
7780 tree gnu_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
7781 gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_ptr);
7783 gnu_result
7784 = build_call_alloc_dealloc (gnu_ptr, gnu_size, gnu_obj_type,
7785 Procedure_To_Call (gnat_node),
7786 Storage_Pool (gnat_node),
7787 gnat_node);
7789 break;
7791 case N_Raise_Constraint_Error:
7792 case N_Raise_Program_Error:
7793 case N_Raise_Storage_Error:
7794 if (type_annotate_only)
7795 gnu_result = alloc_stmt_list ();
7796 else
7797 gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type);
7798 break;
7800 case N_Validate_Unchecked_Conversion:
7801 /* The only validation we currently do on an unchecked conversion is
7802 that of aliasing assumptions. */
7803 if (flag_strict_aliasing)
7804 gnat_validate_uc_list.safe_push (gnat_node);
7805 gnu_result = alloc_stmt_list ();
7806 break;
7808 case N_Function_Specification:
7809 case N_Procedure_Specification:
7810 case N_Op_Concat:
7811 case N_Component_Association:
7812 /* These nodes should only be present when annotating types. */
7813 gcc_assert (type_annotate_only);
7814 gnu_result = alloc_stmt_list ();
7815 break;
7817 default:
7818 /* Other nodes are not supposed to reach here. */
7819 gcc_unreachable ();
7822 /* If we pushed the processing of the elaboration routine, pop it back. */
7823 if (went_into_elab_proc)
7824 current_function_decl = NULL_TREE;
7826 /* When not optimizing, turn boolean rvalues B into B != false tests
7827 so that we can put the location information of the reference to B on
7828 the inequality operator for better debug info. */
7829 if (!optimize
7830 && TREE_CODE (gnu_result) != INTEGER_CST
7831 && TREE_CODE (gnu_result) != TYPE_DECL
7832 && (kind == N_Identifier
7833 || kind == N_Expanded_Name
7834 || kind == N_Explicit_Dereference
7835 || kind == N_Indexed_Component
7836 || kind == N_Selected_Component)
7837 && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
7838 && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
7840 gnu_result
7841 = build_binary_op (NE_EXPR, gnu_result_type,
7842 convert (gnu_result_type, gnu_result),
7843 convert (gnu_result_type, boolean_false_node));
7844 if (TREE_CODE (gnu_result) != INTEGER_CST)
7845 set_gnu_expr_location_from_node (gnu_result, gnat_node);
7848 /* Set the location information on the result if it's not a simple name.
7849 Note that we may have no result if we tried to build a CALL_EXPR node
7850 to a procedure with no side-effects and optimization is enabled. */
7851 else if (kind != N_Identifier && gnu_result && EXPR_P (gnu_result))
7852 set_gnu_expr_location_from_node (gnu_result, gnat_node);
7854 /* If we're supposed to return something of void_type, it means we have
7855 something we're elaborating for effect, so just return. */
7856 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
7857 return gnu_result;
7859 /* If the result is a constant that overflowed, raise Constraint_Error. */
7860 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
7862 post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
7863 gnu_result
7864 = build1 (NULL_EXPR, gnu_result_type,
7865 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
7866 N_Raise_Constraint_Error));
7869 /* If the result has side-effects and is of an unconstrained type, protect
7870 the expression in case it will be referenced multiple times, i.e. for
7871 its value and to compute the size of an object. But do it neither for
7872 an object nor a renaming declaration, nor a return statement of a call
7873 to a function that returns an unconstrained record type with default
7874 discriminant, because there is no size to be computed in these cases
7875 and this will create a useless temporary. We must do this before any
7876 conversions. */
7877 if (TREE_SIDE_EFFECTS (gnu_result)
7878 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
7879 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
7880 && !(TREE_CODE (gnu_result) == CALL_EXPR
7881 && type_is_padding_self_referential (TREE_TYPE (gnu_result))
7882 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
7883 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration
7884 || Nkind (Parent (gnat_node)) == N_Simple_Return_Statement)))
7885 gnu_result = gnat_protect_expr (gnu_result);
7887 /* Now convert the result to the result type, unless we are in one of the
7888 following cases:
7890 1. If this is the LHS of an assignment or an actual parameter of a
7891 call, return the result almost unmodified since the RHS will have
7892 to be converted to our type in that case, unless the result type
7893 has a simpler size. Likewise if there is just a no-op unchecked
7894 conversion in-between. Similarly, don't convert integral types
7895 that are the operands of an unchecked conversion since we need
7896 to ignore those conversions (for 'Valid).
7898 2. If we have a label (which doesn't have any well-defined type), a
7899 field or an error, return the result almost unmodified. Similarly,
7900 if the two types are record types with the same name, don't convert.
7901 This will be the case when we are converting from a packable version
7902 of a type to its original type and we need those conversions to be
7903 NOPs in order for assignments into these types to work properly.
7905 3. If the type is void or if we have no result, return error_mark_node
7906 to show we have no result.
7908 4. If this is a call to a function that returns with variable size and
7909 the call is used as the expression in either an object or a renaming
7910 declaration, return the result unmodified because we want to use the
7911 return slot optimization in this case.
7913 5. Finally, if the type of the result is already correct. */
7915 if (Present (Parent (gnat_node))
7916 && (lhs_or_actual_p (gnat_node)
7917 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
7918 && unchecked_conversion_nop (Parent (gnat_node)))
7919 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
7920 && !AGGREGATE_TYPE_P (gnu_result_type)
7921 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
7922 && !(TYPE_SIZE (gnu_result_type)
7923 && TYPE_SIZE (TREE_TYPE (gnu_result))
7924 && (AGGREGATE_TYPE_P (gnu_result_type)
7925 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
7926 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
7927 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
7928 != INTEGER_CST))
7929 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
7930 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
7931 && (CONTAINS_PLACEHOLDER_P
7932 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
7933 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
7934 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
7936 /* Remove padding only if the inner object is of self-referential
7937 size: in that case it must be an object of unconstrained type
7938 with a default discriminant and we want to avoid copying too
7939 much data. */
7940 if (type_is_padding_self_referential (TREE_TYPE (gnu_result)))
7941 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
7942 gnu_result);
7945 else if (TREE_CODE (gnu_result) == LABEL_DECL
7946 || TREE_CODE (gnu_result) == FIELD_DECL
7947 || TREE_CODE (gnu_result) == ERROR_MARK
7948 || (TYPE_NAME (gnu_result_type)
7949 == TYPE_NAME (TREE_TYPE (gnu_result))
7950 && TREE_CODE (gnu_result_type) == RECORD_TYPE
7951 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
7953 /* Remove any padding. */
7954 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
7955 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
7956 gnu_result);
7959 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
7960 gnu_result = error_mark_node;
7962 else if (Present (Parent (gnat_node))
7963 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
7964 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration)
7965 && TREE_CODE (gnu_result) == CALL_EXPR
7966 && return_type_with_variable_size_p (TREE_TYPE (gnu_result)))
7969 else if (TREE_TYPE (gnu_result) != gnu_result_type)
7970 gnu_result = convert (gnu_result_type, gnu_result);
7972 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
7973 while ((TREE_CODE (gnu_result) == NOP_EXPR
7974 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
7975 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
7976 gnu_result = TREE_OPERAND (gnu_result, 0);
7978 return gnu_result;
7981 /* Similar to gnat_to_gnu, but discard any object that might be created in
7982 the course of the translation of GNAT_NODE, which must be an "external"
7983 expression in the sense that it will be elaborated elsewhere. */
7985 tree
7986 gnat_to_gnu_external (Node_Id gnat_node)
7988 const int save_force_global = force_global;
7989 bool went_into_elab_proc = false;
7991 /* Force the local context and create a fake scope that we zap
7992 at the end so declarations will not be stuck either in the
7993 global varpool or in the current scope. */
7994 if (!current_function_decl)
7996 current_function_decl = get_elaboration_procedure ();
7997 went_into_elab_proc = true;
7999 force_global = 0;
8000 gnat_pushlevel ();
8002 tree gnu_result = gnat_to_gnu (gnat_node);
8004 gnat_zaplevel ();
8005 force_global = save_force_global;
8006 if (went_into_elab_proc)
8007 current_function_decl = NULL_TREE;
8009 /* Do not import locations from external units. */
8010 if (gnu_result && EXPR_P (gnu_result))
8011 SET_EXPR_LOCATION (gnu_result, UNKNOWN_LOCATION);
8013 return gnu_result;
8016 /* Subroutine of above to push the exception label stack. GNU_STACK is
8017 a pointer to the stack to update and GNAT_LABEL, if present, is the
8018 label to push onto the stack. */
8020 static void
8021 push_exception_label_stack (vec<tree, va_gc> **gnu_stack, Entity_Id gnat_label)
8023 tree gnu_label = (Present (gnat_label)
8024 ? gnat_to_gnu_entity (gnat_label, NULL_TREE, false)
8025 : NULL_TREE);
8027 vec_safe_push (*gnu_stack, gnu_label);
8030 /* Return true if the statement list STMT_LIST is empty. */
8032 static bool
8033 empty_stmt_list_p (tree stmt_list)
8035 tree_stmt_iterator tsi;
8037 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
8039 tree stmt = tsi_stmt (tsi);
8041 /* Anything else than an empty STMT_STMT counts as something. */
8042 if (TREE_CODE (stmt) != STMT_STMT || STMT_STMT_STMT (stmt))
8043 return false;
8046 return true;
8049 /* Record the current code position in GNAT_NODE. */
8051 static void
8052 record_code_position (Node_Id gnat_node)
8054 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
8056 add_stmt_with_node (stmt_stmt, gnat_node);
8057 save_gnu_tree (gnat_node, stmt_stmt, true);
8060 /* Insert the code for GNAT_NODE at the position saved for that node. */
8062 static void
8063 insert_code_for (Node_Id gnat_node)
8065 tree code = gnat_to_gnu (gnat_node);
8067 /* It's too late to remove the STMT_STMT itself at this point. */
8068 if (!empty_stmt_list_p (code))
8069 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = code;
8071 save_gnu_tree (gnat_node, NULL_TREE, true);
8074 /* Start a new statement group chained to the previous group. */
8076 void
8077 start_stmt_group (void)
8079 struct stmt_group *group = stmt_group_free_list;
8081 /* First see if we can get one from the free list. */
8082 if (group)
8083 stmt_group_free_list = group->previous;
8084 else
8085 group = ggc_alloc<stmt_group> ();
8087 group->previous = current_stmt_group;
8088 group->stmt_list = group->block = group->cleanups = NULL_TREE;
8089 current_stmt_group = group;
8092 /* Add GNU_STMT to the current statement group. If it is an expression with
8093 no effects, it is ignored. */
8095 void
8096 add_stmt (tree gnu_stmt)
8098 append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
8101 /* Similar, but the statement is always added, regardless of side-effects. */
8103 void
8104 add_stmt_force (tree gnu_stmt)
8106 append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
8109 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
8111 void
8112 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
8114 /* Do not emit a location for renamings that come from generic instantiation,
8115 they are likely to disturb debugging. */
8116 if (Present (gnat_node)
8117 && !renaming_from_generic_instantiation_p (gnat_node))
8118 set_expr_location_from_node (gnu_stmt, gnat_node);
8119 add_stmt (gnu_stmt);
8122 /* Similar, but the statement is always added, regardless of side-effects. */
8124 void
8125 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
8127 if (Present (gnat_node))
8128 set_expr_location_from_node (gnu_stmt, gnat_node);
8129 add_stmt_force (gnu_stmt);
8132 /* Add a declaration statement for GNU_DECL to the current statement group.
8133 Get SLOC from Entity_Id. */
8135 void
8136 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
8138 tree type = TREE_TYPE (gnu_decl);
8139 tree gnu_stmt, gnu_init;
8141 /* If this is a variable that Gigi is to ignore, we may have been given
8142 an ERROR_MARK. So test for it. We also might have been given a
8143 reference for a renaming. So only do something for a decl. Also
8144 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
8145 if (!DECL_P (gnu_decl)
8146 || (TREE_CODE (gnu_decl) == TYPE_DECL
8147 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
8148 return;
8150 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
8152 /* If we are external or global, we don't want to output the DECL_EXPR for
8153 this DECL node since we already have evaluated the expressions in the
8154 sizes and positions as globals and doing it again would be wrong. */
8155 if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ())
8157 /* Mark everything as used to prevent node sharing with subprograms.
8158 Note that walk_tree knows how to deal with TYPE_DECL, but neither
8159 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
8160 MARK_VISITED (gnu_stmt);
8161 if (TREE_CODE (gnu_decl) == VAR_DECL
8162 || TREE_CODE (gnu_decl) == CONST_DECL)
8164 MARK_VISITED (DECL_SIZE (gnu_decl));
8165 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
8166 MARK_VISITED (DECL_INITIAL (gnu_decl));
8168 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
8169 else if (TREE_CODE (gnu_decl) == TYPE_DECL
8170 && RECORD_OR_UNION_TYPE_P (type)
8171 && !TYPE_FAT_POINTER_P (type))
8172 MARK_VISITED (TYPE_ADA_SIZE (type));
8174 else
8175 add_stmt_with_node (gnu_stmt, gnat_entity);
8177 /* If this is a variable and an initializer is attached to it, it must be
8178 valid for the context. Similar to init_const in create_var_decl. */
8179 if (TREE_CODE (gnu_decl) == VAR_DECL
8180 && (gnu_init = DECL_INITIAL (gnu_decl))
8181 && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
8182 || (TREE_STATIC (gnu_decl)
8183 && !initializer_constant_valid_p (gnu_init,
8184 TREE_TYPE (gnu_init)))))
8186 DECL_INITIAL (gnu_decl) = NULL_TREE;
8187 if (TREE_READONLY (gnu_decl))
8189 TREE_READONLY (gnu_decl) = 0;
8190 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
8193 /* If GNU_DECL has a padded type, convert it to the unpadded
8194 type so the assignment is done properly. */
8195 if (TYPE_IS_PADDING_P (type))
8196 gnu_decl = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
8198 gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init);
8199 add_stmt_with_node (gnu_stmt, gnat_entity);
8203 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
8205 static tree
8206 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
8208 tree t = *tp;
8210 if (TREE_VISITED (t))
8211 *walk_subtrees = 0;
8213 /* Don't mark a dummy type as visited because we want to mark its sizes
8214 and fields once it's filled in. */
8215 else if (!TYPE_IS_DUMMY_P (t))
8216 TREE_VISITED (t) = 1;
8218 if (TYPE_P (t))
8219 TYPE_SIZES_GIMPLIFIED (t) = 1;
8221 return NULL_TREE;
8224 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8225 sized gimplified. We use this to indicate all variable sizes and
8226 positions in global types may not be shared by any subprogram. */
8228 void
8229 mark_visited (tree t)
8231 walk_tree (&t, mark_visited_r, NULL, NULL);
8234 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8235 set its location to that of GNAT_NODE if present, but with column info
8236 cleared so that conditional branches generated as part of the cleanup
8237 code do not interfere with coverage analysis tools. */
8239 static void
8240 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
8242 if (Present (gnat_node))
8243 set_expr_location_from_node (gnu_cleanup, gnat_node, true);
8244 append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
8247 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8249 void
8250 set_block_for_group (tree gnu_block)
8252 gcc_assert (!current_stmt_group->block);
8253 current_stmt_group->block = gnu_block;
8256 /* Return code corresponding to the current code group. It is normally
8257 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
8258 BLOCK or cleanups were set. */
8260 tree
8261 end_stmt_group (void)
8263 struct stmt_group *group = current_stmt_group;
8264 tree gnu_retval = group->stmt_list;
8266 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
8267 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
8268 make a BIND_EXPR. Note that we nest in that because the cleanup may
8269 reference variables in the block. */
8270 if (!gnu_retval)
8271 gnu_retval = alloc_stmt_list ();
8273 if (group->cleanups)
8274 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
8275 group->cleanups);
8277 if (current_stmt_group->block)
8278 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
8279 gnu_retval, group->block);
8281 /* Remove this group from the stack and add it to the free list. */
8282 current_stmt_group = group->previous;
8283 group->previous = stmt_group_free_list;
8284 stmt_group_free_list = group;
8286 return gnu_retval;
8289 /* Return whether the current statement group may fall through. */
8291 static inline bool
8292 stmt_group_may_fallthru (void)
8294 if (current_stmt_group->stmt_list)
8295 return block_may_fallthru (current_stmt_group->stmt_list);
8296 else
8297 return true;
8300 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
8301 statements.*/
8303 static void
8304 add_stmt_list (List_Id gnat_list)
8306 Node_Id gnat_node;
8308 if (Present (gnat_list))
8309 for (gnat_node = First (gnat_list); Present (gnat_node);
8310 gnat_node = Next (gnat_node))
8311 add_stmt (gnat_to_gnu (gnat_node));
8314 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
8315 If BINDING_P is true, push and pop a binding level around the list. */
8317 static tree
8318 build_stmt_group (List_Id gnat_list, bool binding_p)
8320 start_stmt_group ();
8322 if (binding_p)
8323 gnat_pushlevel ();
8325 add_stmt_list (gnat_list);
8327 if (binding_p)
8328 gnat_poplevel ();
8330 return end_stmt_group ();
8333 /* Generate GIMPLE in place for the expression at *EXPR_P. */
8336 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
8337 gimple_seq *post_p ATTRIBUTE_UNUSED)
8339 tree expr = *expr_p;
8340 tree type = TREE_TYPE (expr);
8341 tree op;
8343 if (IS_ADA_STMT (expr))
8344 return gnat_gimplify_stmt (expr_p);
8346 switch (TREE_CODE (expr))
8348 case NULL_EXPR:
8349 /* If this is an aggregate type, build a null pointer of the appropriate
8350 type and dereference it. */
8351 if (AGGREGATE_TYPE_P (type)
8352 || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
8353 *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE,
8354 convert (build_pointer_type (type),
8355 integer_zero_node));
8356 /* Otherwise, just make a VAR_DECL. */
8357 else
8359 *expr_p = create_tmp_var (type, NULL);
8360 TREE_NO_WARNING (*expr_p) = 1;
8363 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
8364 return GS_OK;
8366 case UNCONSTRAINED_ARRAY_REF:
8367 /* We should only do this if we are just elaborating for side-effects,
8368 but we can't know that yet. */
8369 *expr_p = TREE_OPERAND (*expr_p, 0);
8370 return GS_OK;
8372 case ADDR_EXPR:
8373 op = TREE_OPERAND (expr, 0);
8375 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
8376 is put into static memory. We know that it's going to be read-only
8377 given the semantics we have and it must be in static memory when the
8378 reference is in an elaboration procedure. */
8379 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
8381 tree addr = build_fold_addr_expr (tree_output_constant_def (op));
8382 *expr_p = fold_convert (type, addr);
8383 return GS_ALL_DONE;
8386 /* Replace atomic loads with their first argument. That's necessary
8387 because the gimplifier would create a temporary otherwise. */
8388 if (TREE_SIDE_EFFECTS (op))
8389 while (handled_component_p (op) || CONVERT_EXPR_P (op))
8391 tree inner = TREE_OPERAND (op, 0);
8392 if (TREE_CODE (inner) == CALL_EXPR && call_is_atomic_load (inner))
8394 tree t = CALL_EXPR_ARG (inner, 0);
8395 if (TREE_CODE (t) == NOP_EXPR)
8396 t = TREE_OPERAND (t, 0);
8397 if (TREE_CODE (t) == ADDR_EXPR)
8398 TREE_OPERAND (op, 0) = TREE_OPERAND (t, 0);
8399 else
8400 TREE_OPERAND (op, 0) = build_fold_indirect_ref (t);
8402 else
8403 op = inner;
8406 return GS_UNHANDLED;
8408 case VIEW_CONVERT_EXPR:
8409 op = TREE_OPERAND (expr, 0);
8411 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
8412 type to a scalar one, explicitly create the local temporary. That's
8413 required if the type is passed by reference. */
8414 if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
8415 && AGGREGATE_TYPE_P (TREE_TYPE (op))
8416 && !AGGREGATE_TYPE_P (type))
8418 tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
8419 gimple_add_tmp_var (new_var);
8421 mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
8422 gimplify_and_add (mod, pre_p);
8424 TREE_OPERAND (expr, 0) = new_var;
8425 return GS_OK;
8428 return GS_UNHANDLED;
8430 case DECL_EXPR:
8431 op = DECL_EXPR_DECL (expr);
8433 /* The expressions for the RM bounds must be gimplified to ensure that
8434 they are properly elaborated. See gimplify_decl_expr. */
8435 if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
8436 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
8437 switch (TREE_CODE (TREE_TYPE (op)))
8439 case INTEGER_TYPE:
8440 case ENUMERAL_TYPE:
8441 case BOOLEAN_TYPE:
8442 case REAL_TYPE:
8444 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
8446 val = TYPE_RM_MIN_VALUE (type);
8447 if (val)
8449 gimplify_one_sizepos (&val, pre_p);
8450 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8451 SET_TYPE_RM_MIN_VALUE (t, val);
8454 val = TYPE_RM_MAX_VALUE (type);
8455 if (val)
8457 gimplify_one_sizepos (&val, pre_p);
8458 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8459 SET_TYPE_RM_MAX_VALUE (t, val);
8463 break;
8465 default:
8466 break;
8469 /* ... fall through ... */
8471 default:
8472 return GS_UNHANDLED;
8476 /* Generate GIMPLE in place for the statement at *STMT_P. */
8478 static enum gimplify_status
8479 gnat_gimplify_stmt (tree *stmt_p)
8481 tree stmt = *stmt_p;
8483 switch (TREE_CODE (stmt))
8485 case STMT_STMT:
8486 *stmt_p = STMT_STMT_STMT (stmt);
8487 return GS_OK;
8489 case LOOP_STMT:
8491 tree gnu_start_label = create_artificial_label (input_location);
8492 tree gnu_cond = LOOP_STMT_COND (stmt);
8493 tree gnu_update = LOOP_STMT_UPDATE (stmt);
8494 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
8496 /* Build the condition expression from the test, if any. */
8497 if (gnu_cond)
8499 /* Deal with the optimization hints. */
8500 if (LOOP_STMT_IVDEP (stmt))
8501 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8502 build_int_cst (integer_type_node,
8503 annot_expr_ivdep_kind));
8504 if (LOOP_STMT_NO_VECTOR (stmt))
8505 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8506 build_int_cst (integer_type_node,
8507 annot_expr_no_vector_kind));
8508 if (LOOP_STMT_VECTOR (stmt))
8509 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8510 build_int_cst (integer_type_node,
8511 annot_expr_vector_kind));
8513 gnu_cond
8514 = build3 (COND_EXPR, void_type_node, gnu_cond, NULL_TREE,
8515 build1 (GOTO_EXPR, void_type_node, gnu_end_label));
8518 /* Set to emit the statements of the loop. */
8519 *stmt_p = NULL_TREE;
8521 /* We first emit the start label and then a conditional jump to the
8522 end label if there's a top condition, then the update if it's at
8523 the top, then the body of the loop, then a conditional jump to
8524 the end label if there's a bottom condition, then the update if
8525 it's at the bottom, and finally a jump to the start label and the
8526 definition of the end label. */
8527 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
8528 gnu_start_label),
8529 stmt_p);
8531 if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
8532 append_to_statement_list (gnu_cond, stmt_p);
8534 if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
8535 append_to_statement_list (gnu_update, stmt_p);
8537 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
8539 if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
8540 append_to_statement_list (gnu_cond, stmt_p);
8542 if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
8543 append_to_statement_list (gnu_update, stmt_p);
8545 tree t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
8546 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
8547 append_to_statement_list (t, stmt_p);
8549 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
8550 gnu_end_label),
8551 stmt_p);
8552 return GS_OK;
8555 case EXIT_STMT:
8556 /* Build a statement to jump to the corresponding end label, then
8557 see if it needs to be conditional. */
8558 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
8559 if (EXIT_STMT_COND (stmt))
8560 *stmt_p = build3 (COND_EXPR, void_type_node,
8561 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
8562 return GS_OK;
8564 default:
8565 gcc_unreachable ();
8569 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
8571 This routine is exclusively called in type_annotate mode, to compute DDA
8572 information for types in withed units, for ASIS use. */
8574 static void
8575 elaborate_all_entities_for_package (Entity_Id gnat_package)
8577 Entity_Id gnat_entity;
8579 for (gnat_entity = First_Entity (gnat_package);
8580 Present (gnat_entity);
8581 gnat_entity = Next_Entity (gnat_entity))
8583 const Entity_Kind kind = Ekind (gnat_entity);
8585 /* We are interested only in entities visible from the main unit. */
8586 if (!Is_Public (gnat_entity))
8587 continue;
8589 /* Skip stuff internal to the compiler. */
8590 if (Convention (gnat_entity) == Convention_Intrinsic)
8591 continue;
8592 if (kind == E_Operator)
8593 continue;
8594 if (IN (kind, Subprogram_Kind) && Is_Intrinsic_Subprogram (gnat_entity))
8595 continue;
8596 if (Is_Itype (gnat_entity))
8597 continue;
8599 /* Skip named numbers. */
8600 if (IN (kind, Named_Kind))
8601 continue;
8603 /* Skip generic declarations. */
8604 if (IN (kind, Generic_Unit_Kind))
8605 continue;
8607 /* Skip formal objects. */
8608 if (IN (kind, Formal_Object_Kind))
8609 continue;
8611 /* Skip package bodies. */
8612 if (kind == E_Package_Body)
8613 continue;
8615 /* Skip limited views that point back to the main unit. */
8616 if (IN (kind, Incomplete_Kind)
8617 && From_Limited_With (gnat_entity)
8618 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity)))
8619 continue;
8621 /* Skip types that aren't frozen. */
8622 if (IN (kind, Type_Kind) && !Is_Frozen (gnat_entity))
8623 continue;
8625 /* Recurse on real packages that aren't in the main unit. */
8626 if (kind == E_Package)
8628 if (No (Renamed_Entity (gnat_entity))
8629 && !In_Extended_Main_Code_Unit (gnat_entity))
8630 elaborate_all_entities_for_package (gnat_entity);
8632 else
8633 gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
8637 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
8638 Operate recursively but check that we aren't elaborating something more
8639 than once.
8641 This routine is exclusively called in type_annotate mode, to compute DDA
8642 information for types in withed units, for ASIS use. */
8644 static void
8645 elaborate_all_entities (Node_Id gnat_node)
8647 Entity_Id gnat_with_clause;
8649 /* Process each unit only once. As we trace the context of all relevant
8650 units transitively, including generic bodies, we may encounter the
8651 same generic unit repeatedly. */
8652 if (!present_gnu_tree (gnat_node))
8653 save_gnu_tree (gnat_node, integer_zero_node, true);
8655 /* Save entities in all context units. A body may have an implicit_with
8656 on its own spec, if the context includes a child unit, so don't save
8657 the spec twice. */
8658 for (gnat_with_clause = First (Context_Items (gnat_node));
8659 Present (gnat_with_clause);
8660 gnat_with_clause = Next (gnat_with_clause))
8661 if (Nkind (gnat_with_clause) == N_With_Clause
8662 && !present_gnu_tree (Library_Unit (gnat_with_clause))
8663 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
8665 Node_Id gnat_unit = Library_Unit (gnat_with_clause);
8666 Entity_Id gnat_entity = Entity (Name (gnat_with_clause));
8668 elaborate_all_entities (gnat_unit);
8670 if (Ekind (gnat_entity) == E_Package)
8671 elaborate_all_entities_for_package (gnat_entity);
8673 else if (Ekind (gnat_entity) == E_Generic_Package)
8675 Node_Id gnat_body = Corresponding_Body (Unit (gnat_unit));
8677 /* Retrieve compilation unit node of generic body. */
8678 while (Present (gnat_body)
8679 && Nkind (gnat_body) != N_Compilation_Unit)
8680 gnat_body = Parent (gnat_body);
8682 /* If body is available, elaborate its context. */
8683 if (Present (gnat_body))
8684 elaborate_all_entities (gnat_body);
8688 if (Nkind (Unit (gnat_node)) == N_Package_Body)
8689 elaborate_all_entities (Library_Unit (gnat_node));
8692 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
8694 static void
8695 process_freeze_entity (Node_Id gnat_node)
8697 const Entity_Id gnat_entity = Entity (gnat_node);
8698 const Entity_Kind kind = Ekind (gnat_entity);
8699 tree gnu_old, gnu_new;
8701 /* If this is a package, we need to generate code for the package. */
8702 if (kind == E_Package)
8704 insert_code_for
8705 (Parent (Corresponding_Body
8706 (Parent (Declaration_Node (gnat_entity)))));
8707 return;
8710 /* Don't do anything for class-wide types as they are always transformed
8711 into their root type. */
8712 if (kind == E_Class_Wide_Type)
8713 return;
8715 /* Check for an old definition if this isn't an object with address clause,
8716 since the saved GCC tree is the address expression in that case. */
8717 gnu_old
8718 = present_gnu_tree (gnat_entity) && No (Address_Clause (gnat_entity))
8719 ? get_gnu_tree (gnat_entity) : NULL_TREE;
8721 /* Don't do anything for subprograms that may have been elaborated before
8722 their freeze nodes. This can happen, for example, because of an inner
8723 call in an instance body or because of previous compilation of a spec
8724 for inlining purposes. */
8725 if (gnu_old
8726 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
8727 && (kind == E_Function || kind == E_Procedure))
8728 || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
8729 && kind == E_Subprogram_Type)))
8730 return;
8732 /* If we have a non-dummy type old tree, we have nothing to do, except for
8733 aborting, since this node was never delayed as it should have been. We
8734 let this happen for concurrent types and their Corresponding_Record_Type,
8735 however, because each might legitimately be elaborated before its own
8736 freeze node, e.g. while processing the other. */
8737 if (gnu_old
8738 && !(TREE_CODE (gnu_old) == TYPE_DECL
8739 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
8741 gcc_assert (Is_Concurrent_Type (gnat_entity)
8742 || (Is_Record_Type (gnat_entity)
8743 && Is_Concurrent_Record_Type (gnat_entity)));
8744 return;
8747 /* Reset the saved tree, if any, and elaborate the object or type for real.
8748 If there is a full view, elaborate it and use the result. And, if this
8749 is the root type of a class-wide type, reuse it for the latter. */
8750 if (gnu_old)
8752 save_gnu_tree (gnat_entity, NULL_TREE, false);
8754 if (IN (kind, Incomplete_Or_Private_Kind)
8755 && Present (Full_View (gnat_entity)))
8757 Entity_Id full_view = Full_View (gnat_entity);
8759 save_gnu_tree (full_view, NULL_TREE, false);
8761 if (IN (Ekind (full_view), Private_Kind)
8762 && Present (Underlying_Full_View (full_view)))
8764 full_view = Underlying_Full_View (full_view);
8765 save_gnu_tree (full_view, NULL_TREE, false);
8769 if (IN (kind, Type_Kind)
8770 && Present (Class_Wide_Type (gnat_entity))
8771 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
8772 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
8775 if (IN (kind, Incomplete_Or_Private_Kind)
8776 && Present (Full_View (gnat_entity)))
8778 Entity_Id full_view = Full_View (gnat_entity);
8780 if (IN (Ekind (full_view), Private_Kind)
8781 && Present (Underlying_Full_View (full_view)))
8782 full_view = Underlying_Full_View (full_view);
8784 gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, true);
8786 /* Propagate back-annotations from full view to partial view. */
8787 if (Unknown_Alignment (gnat_entity))
8788 Set_Alignment (gnat_entity, Alignment (full_view));
8790 if (Unknown_Esize (gnat_entity))
8791 Set_Esize (gnat_entity, Esize (full_view));
8793 if (Unknown_RM_Size (gnat_entity))
8794 Set_RM_Size (gnat_entity, RM_Size (full_view));
8796 /* The above call may have defined this entity (the simplest example
8797 of this is when we have a private enumeral type since the bounds
8798 will have the public view). */
8799 if (!present_gnu_tree (gnat_entity))
8800 save_gnu_tree (gnat_entity, gnu_new, false);
8802 else
8804 tree gnu_init
8805 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
8806 && present_gnu_tree (Declaration_Node (gnat_entity)))
8807 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
8809 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, true);
8812 if (IN (kind, Type_Kind)
8813 && Present (Class_Wide_Type (gnat_entity))
8814 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
8815 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
8817 /* If we have an old type and we've made pointers to this type, update those
8818 pointers. If this is a Taft amendment type in the main unit, we need to
8819 mark the type as used since other units referencing it don't see the full
8820 declaration and, therefore, cannot mark it as used themselves. */
8821 if (gnu_old)
8823 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
8824 TREE_TYPE (gnu_new));
8825 if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old)))
8826 update_profiles_with (TREE_TYPE (gnu_old));
8827 if (DECL_TAFT_TYPE_P (gnu_old))
8828 used_types_insert (TREE_TYPE (gnu_new));
8832 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
8833 We make two passes, one to elaborate anything other than bodies (but
8834 we declare a function if there was no spec). The second pass
8835 elaborates the bodies.
8837 GNAT_END_LIST gives the element in the list past the end. Normally,
8838 this is Empty, but can be First_Real_Statement for a
8839 Handled_Sequence_Of_Statements.
8841 We make a complete pass through both lists if PASS1P is true, then make
8842 the second pass over both lists if PASS2P is true. The lists usually
8843 correspond to the public and private parts of a package. */
8845 static void
8846 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
8847 Node_Id gnat_end_list, bool pass1p, bool pass2p)
8849 List_Id gnat_decl_array[2];
8850 Node_Id gnat_decl;
8851 int i;
8853 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
8855 if (pass1p)
8856 for (i = 0; i <= 1; i++)
8857 if (Present (gnat_decl_array[i]))
8858 for (gnat_decl = First (gnat_decl_array[i]);
8859 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
8861 /* For package specs, we recurse inside the declarations,
8862 thus taking the two pass approach inside the boundary. */
8863 if (Nkind (gnat_decl) == N_Package_Declaration
8864 && (Nkind (Specification (gnat_decl)
8865 == N_Package_Specification)))
8866 process_decls (Visible_Declarations (Specification (gnat_decl)),
8867 Private_Declarations (Specification (gnat_decl)),
8868 Empty, true, false);
8870 /* Similarly for any declarations in the actions of a
8871 freeze node. */
8872 else if (Nkind (gnat_decl) == N_Freeze_Entity)
8874 process_freeze_entity (gnat_decl);
8875 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
8878 /* Package bodies with freeze nodes get their elaboration deferred
8879 until the freeze node, but the code must be placed in the right
8880 place, so record the code position now. */
8881 else if (Nkind (gnat_decl) == N_Package_Body
8882 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
8883 record_code_position (gnat_decl);
8885 else if (Nkind (gnat_decl) == N_Package_Body_Stub
8886 && Present (Library_Unit (gnat_decl))
8887 && Present (Freeze_Node
8888 (Corresponding_Spec
8889 (Proper_Body (Unit
8890 (Library_Unit (gnat_decl)))))))
8891 record_code_position
8892 (Proper_Body (Unit (Library_Unit (gnat_decl))));
8894 /* We defer most subprogram bodies to the second pass. */
8895 else if (Nkind (gnat_decl) == N_Subprogram_Body)
8897 if (Acts_As_Spec (gnat_decl))
8899 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
8901 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
8902 && Ekind (gnat_subprog_id) != E_Generic_Function)
8903 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, true);
8907 /* For bodies and stubs that act as their own specs, the entity
8908 itself must be elaborated in the first pass, because it may
8909 be used in other declarations. */
8910 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
8912 Node_Id gnat_subprog_id
8913 = Defining_Entity (Specification (gnat_decl));
8915 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
8916 && Ekind (gnat_subprog_id) != E_Generic_Procedure
8917 && Ekind (gnat_subprog_id) != E_Generic_Function)
8918 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, true);
8921 /* Concurrent stubs stand for the corresponding subprogram bodies,
8922 which are deferred like other bodies. */
8923 else if (Nkind (gnat_decl) == N_Task_Body_Stub
8924 || Nkind (gnat_decl) == N_Protected_Body_Stub)
8927 /* Renamed subprograms may not be elaborated yet at this point
8928 since renamings do not trigger freezing. Wait for the second
8929 pass to take care of them. */
8930 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
8933 else
8934 add_stmt (gnat_to_gnu (gnat_decl));
8937 /* Here we elaborate everything we deferred above except for package bodies,
8938 which are elaborated at their freeze nodes. Note that we must also
8939 go inside things (package specs and freeze nodes) the first pass did. */
8940 if (pass2p)
8941 for (i = 0; i <= 1; i++)
8942 if (Present (gnat_decl_array[i]))
8943 for (gnat_decl = First (gnat_decl_array[i]);
8944 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
8946 if (Nkind (gnat_decl) == N_Subprogram_Body
8947 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
8948 || Nkind (gnat_decl) == N_Task_Body_Stub
8949 || Nkind (gnat_decl) == N_Protected_Body_Stub)
8950 add_stmt (gnat_to_gnu (gnat_decl));
8952 else if (Nkind (gnat_decl) == N_Package_Declaration
8953 && (Nkind (Specification (gnat_decl)
8954 == N_Package_Specification)))
8955 process_decls (Visible_Declarations (Specification (gnat_decl)),
8956 Private_Declarations (Specification (gnat_decl)),
8957 Empty, false, true);
8959 else if (Nkind (gnat_decl) == N_Freeze_Entity)
8960 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
8962 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
8963 add_stmt (gnat_to_gnu (gnat_decl));
8967 /* Make a unary operation of kind CODE using build_unary_op, but guard
8968 the operation by an overflow check. CODE can be one of NEGATE_EXPR
8969 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
8970 the operation is to be performed in that type. GNAT_NODE is the gnat
8971 node conveying the source location for which the error should be
8972 signaled. */
8974 static tree
8975 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
8976 Node_Id gnat_node)
8978 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
8980 operand = gnat_protect_expr (operand);
8982 return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
8983 operand, TYPE_MIN_VALUE (gnu_type)),
8984 build_unary_op (code, gnu_type, operand),
8985 CE_Overflow_Check_Failed, gnat_node);
8988 /* Make a binary operation of kind CODE using build_binary_op, but guard
8989 the operation by an overflow check. CODE can be one of PLUS_EXPR,
8990 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
8991 Usually the operation is to be performed in that type. GNAT_NODE is
8992 the GNAT node conveying the source location for which the error should
8993 be signaled. */
8995 static tree
8996 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
8997 tree right, Node_Id gnat_node)
8999 const unsigned int precision = TYPE_PRECISION (gnu_type);
9000 tree lhs = gnat_protect_expr (left);
9001 tree rhs = gnat_protect_expr (right);
9002 tree type_max = TYPE_MAX_VALUE (gnu_type);
9003 tree type_min = TYPE_MIN_VALUE (gnu_type);
9004 tree gnu_expr, check;
9005 int sgn;
9007 /* Assert that the precision is a power of 2. */
9008 gcc_assert ((precision & (precision - 1)) == 0);
9010 /* Prefer a constant on the RHS to simplify checks. */
9011 if (TREE_CODE (rhs) != INTEGER_CST
9012 && TREE_CODE (lhs) == INTEGER_CST
9013 && (code == PLUS_EXPR || code == MULT_EXPR))
9015 tree tmp = lhs;
9016 lhs = rhs;
9017 rhs = tmp;
9020 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
9022 /* If we can fold the expression to a constant, just return it.
9023 The caller will deal with overflow, no need to generate a check. */
9024 if (TREE_CODE (gnu_expr) == INTEGER_CST)
9025 return gnu_expr;
9027 /* If no operand is a constant, we use the generic implementation. */
9028 if (TREE_CODE (lhs) != INTEGER_CST && TREE_CODE (rhs) != INTEGER_CST)
9030 /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
9031 if (code == MULT_EXPR && precision == 64 && BITS_PER_WORD < 64)
9033 tree int64 = gnat_type_for_size (64, 0);
9034 return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
9035 convert (int64, lhs),
9036 convert (int64, rhs)));
9039 enum internal_fn icode;
9041 switch (code)
9043 case PLUS_EXPR:
9044 icode = IFN_ADD_OVERFLOW;
9045 break;
9046 case MINUS_EXPR:
9047 icode = IFN_SUB_OVERFLOW;
9048 break;
9049 case MULT_EXPR:
9050 icode = IFN_MUL_OVERFLOW;
9051 break;
9052 default:
9053 gcc_unreachable ();
9056 tree gnu_ctype = build_complex_type (gnu_type);
9057 tree call
9058 = build_call_expr_internal_loc (UNKNOWN_LOCATION, icode, gnu_ctype, 2,
9059 lhs, rhs);
9060 tree tgt = save_expr (call);
9061 gnu_expr = build1 (REALPART_EXPR, gnu_type, tgt);
9062 check = fold_build2 (NE_EXPR, boolean_type_node,
9063 build1 (IMAGPART_EXPR, gnu_type, tgt),
9064 build_int_cst (gnu_type, 0));
9065 return
9066 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
9069 /* If one operand is a constant, we expose the overflow condition to enable
9070 a subsequent simplication or even elimination. */
9071 switch (code)
9073 case PLUS_EXPR:
9074 sgn = tree_int_cst_sgn (rhs);
9075 if (sgn > 0)
9076 /* When rhs > 0, overflow when lhs > type_max - rhs. */
9077 check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
9078 build_binary_op (MINUS_EXPR, gnu_type,
9079 type_max, rhs));
9080 else if (sgn < 0)
9081 /* When rhs < 0, overflow when lhs < type_min - rhs. */
9082 check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
9083 build_binary_op (MINUS_EXPR, gnu_type,
9084 type_min, rhs));
9085 else
9086 return gnu_expr;
9087 break;
9089 case MINUS_EXPR:
9090 if (TREE_CODE (lhs) == INTEGER_CST)
9092 sgn = tree_int_cst_sgn (lhs);
9093 if (sgn > 0)
9094 /* When lhs > 0, overflow when rhs < lhs - type_max. */
9095 check = build_binary_op (LT_EXPR, boolean_type_node, rhs,
9096 build_binary_op (MINUS_EXPR, gnu_type,
9097 lhs, type_max));
9098 else if (sgn < 0)
9099 /* When lhs < 0, overflow when rhs > lhs - type_min. */
9100 check = build_binary_op (GT_EXPR, boolean_type_node, rhs,
9101 build_binary_op (MINUS_EXPR, gnu_type,
9102 lhs, type_min));
9103 else
9104 return gnu_expr;
9106 else
9108 sgn = tree_int_cst_sgn (rhs);
9109 if (sgn > 0)
9110 /* When rhs > 0, overflow when lhs < type_min + rhs. */
9111 check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
9112 build_binary_op (PLUS_EXPR, gnu_type,
9113 type_min, rhs));
9114 else if (sgn < 0)
9115 /* When rhs < 0, overflow when lhs > type_max + rhs. */
9116 check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
9117 build_binary_op (PLUS_EXPR, gnu_type,
9118 type_max, rhs));
9119 else
9120 return gnu_expr;
9122 break;
9124 case MULT_EXPR:
9125 sgn = tree_int_cst_sgn (rhs);
9126 if (sgn > 0)
9128 if (integer_onep (rhs))
9129 return gnu_expr;
9131 tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
9132 tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
9134 /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
9135 check
9136 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9137 build_binary_op (LT_EXPR, boolean_type_node,
9138 lhs, lb),
9139 build_binary_op (GT_EXPR, boolean_type_node,
9140 lhs, ub));
9142 else if (sgn < 0)
9144 tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
9145 tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
9147 if (integer_minus_onep (rhs))
9148 /* When rhs == -1, overflow if lhs == type_min. */
9149 check
9150 = build_binary_op (EQ_EXPR, boolean_type_node, lhs, type_min);
9151 else
9152 /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
9153 check
9154 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9155 build_binary_op (LT_EXPR, boolean_type_node,
9156 lhs, lb),
9157 build_binary_op (GT_EXPR, boolean_type_node,
9158 lhs, ub));
9160 else
9161 return gnu_expr;
9162 break;
9164 default:
9165 gcc_unreachable ();
9168 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
9171 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
9172 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
9173 which we have to check. GNAT_NODE is the GNAT node conveying the source
9174 location for which the error should be signaled. */
9176 static tree
9177 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
9179 tree gnu_range_type = get_unpadded_type (gnat_range_type);
9180 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
9182 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
9183 This can for example happen when translating 'Val or 'Value. */
9184 if (gnu_compare_type == gnu_range_type)
9185 return gnu_expr;
9187 /* Range checks can only be applied to types with ranges. */
9188 gcc_assert (INTEGRAL_TYPE_P (gnu_range_type)
9189 || SCALAR_FLOAT_TYPE_P (gnu_range_type));
9191 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
9192 we can't do anything since we might be truncating the bounds. No
9193 check is needed in this case. */
9194 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
9195 && (TYPE_PRECISION (gnu_compare_type)
9196 < TYPE_PRECISION (get_base_type (gnu_range_type))))
9197 return gnu_expr;
9199 /* Checked expressions must be evaluated only once. */
9200 gnu_expr = gnat_protect_expr (gnu_expr);
9202 /* Note that the form of the check is
9203 (not (expr >= lo)) or (not (expr <= hi))
9204 the reason for this slightly convoluted form is that NaNs
9205 are not considered to be in range in the float case. */
9206 return emit_check
9207 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9208 invert_truthvalue
9209 (build_binary_op (GE_EXPR, boolean_type_node,
9210 convert (gnu_compare_type, gnu_expr),
9211 convert (gnu_compare_type,
9212 TYPE_MIN_VALUE
9213 (gnu_range_type)))),
9214 invert_truthvalue
9215 (build_binary_op (LE_EXPR, boolean_type_node,
9216 convert (gnu_compare_type, gnu_expr),
9217 convert (gnu_compare_type,
9218 TYPE_MAX_VALUE
9219 (gnu_range_type))))),
9220 gnu_expr, CE_Range_Check_Failed, gnat_node);
9223 /* GNU_COND contains the condition corresponding to an index, overflow or
9224 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9225 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9226 REASON is the code that says why the exception is raised. GNAT_NODE is
9227 the node conveying the source location for which the error should be
9228 signaled.
9230 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9231 overwriting the setting inherited from the call statement, on the ground
9232 that the expression need not be evaluated just for the check. However
9233 that's incorrect because, in the GCC type system, its value is presumed
9234 to be valid so its comparison against the type bounds always yields true
9235 and, therefore, could be done without evaluating it; given that it can
9236 be a computation that overflows the bounds, the language may require the
9237 check to fail and thus the expression to be evaluated in this case. */
9239 static tree
9240 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
9242 tree gnu_call
9243 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
9244 return
9245 fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
9246 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
9247 SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr))
9248 ? build_real (TREE_TYPE (gnu_expr), dconst0)
9249 : build_int_cst (TREE_TYPE (gnu_expr), 0)),
9250 gnu_expr);
9253 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
9254 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
9255 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
9256 float to integer conversion with truncation; otherwise round.
9257 GNAT_NODE is the GNAT node conveying the source location for which the
9258 error should be signaled. */
9260 static tree
9261 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
9262 bool rangep, bool truncatep, Node_Id gnat_node)
9264 tree gnu_type = get_unpadded_type (gnat_type);
9265 tree gnu_in_type = TREE_TYPE (gnu_expr);
9266 tree gnu_in_basetype = get_base_type (gnu_in_type);
9267 tree gnu_base_type = get_base_type (gnu_type);
9268 tree gnu_result = gnu_expr;
9270 /* If we are not doing any checks, the output is an integral type and the
9271 input is not a floating-point type, just do the conversion. This is
9272 required for packed array types and is simpler in all cases anyway. */
9273 if (!rangep
9274 && !overflowp
9275 && INTEGRAL_TYPE_P (gnu_base_type)
9276 && !FLOAT_TYPE_P (gnu_in_type))
9277 return convert (gnu_type, gnu_expr);
9279 /* First convert the expression to its base type. This
9280 will never generate code, but makes the tests below much simpler.
9281 But don't do this if converting from an integer type to an unconstrained
9282 array type since then we need to get the bounds from the original
9283 (unpacked) type. */
9284 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
9285 gnu_result = convert (gnu_in_basetype, gnu_result);
9287 /* If overflow checks are requested, we need to be sure the result will
9288 fit in the output base type. But don't do this if the input
9289 is integer and the output floating-point. */
9290 if (overflowp
9291 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
9293 /* Ensure GNU_EXPR only gets evaluated once. */
9294 tree gnu_input = gnat_protect_expr (gnu_result);
9295 tree gnu_cond = boolean_false_node;
9296 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
9297 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
9298 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
9299 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
9301 /* Convert the lower bounds to signed types, so we're sure we're
9302 comparing them properly. Likewise, convert the upper bounds
9303 to unsigned types. */
9304 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
9305 gnu_in_lb
9306 = convert (gnat_signed_type_for (gnu_in_basetype), gnu_in_lb);
9308 if (INTEGRAL_TYPE_P (gnu_in_basetype)
9309 && !TYPE_UNSIGNED (gnu_in_basetype))
9310 gnu_in_ub
9311 = convert (gnat_unsigned_type_for (gnu_in_basetype), gnu_in_ub);
9313 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
9314 gnu_out_lb
9315 = convert (gnat_signed_type_for (gnu_base_type), gnu_out_lb);
9317 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
9318 gnu_out_ub
9319 = convert (gnat_unsigned_type_for (gnu_base_type), gnu_out_ub);
9321 /* Check each bound separately and only if the result bound
9322 is tighter than the bound on the input type. Note that all the
9323 types are base types, so the bounds must be constant. Also,
9324 the comparison is done in the base type of the input, which
9325 always has the proper signedness. First check for input
9326 integer (which means output integer), output float (which means
9327 both float), or mixed, in which case we always compare.
9328 Note that we have to do the comparison which would *fail* in the
9329 case of an error since if it's an FP comparison and one of the
9330 values is a NaN or Inf, the comparison will fail. */
9331 if (INTEGRAL_TYPE_P (gnu_in_basetype)
9332 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
9333 : (FLOAT_TYPE_P (gnu_base_type)
9334 ? real_less (&TREE_REAL_CST (gnu_in_lb),
9335 &TREE_REAL_CST (gnu_out_lb))
9336 : 1))
9337 gnu_cond
9338 = invert_truthvalue
9339 (build_binary_op (GE_EXPR, boolean_type_node,
9340 gnu_input, convert (gnu_in_basetype,
9341 gnu_out_lb)));
9343 if (INTEGRAL_TYPE_P (gnu_in_basetype)
9344 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
9345 : (FLOAT_TYPE_P (gnu_base_type)
9346 ? real_less (&TREE_REAL_CST (gnu_out_ub),
9347 &TREE_REAL_CST (gnu_in_lb))
9348 : 1))
9349 gnu_cond
9350 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
9351 invert_truthvalue
9352 (build_binary_op (LE_EXPR, boolean_type_node,
9353 gnu_input,
9354 convert (gnu_in_basetype,
9355 gnu_out_ub))));
9357 if (!integer_zerop (gnu_cond))
9358 gnu_result = emit_check (gnu_cond, gnu_input,
9359 CE_Overflow_Check_Failed, gnat_node);
9362 /* Now convert to the result base type. If this is a non-truncating
9363 float-to-integer conversion, round. */
9364 if (INTEGRAL_TYPE_P (gnu_base_type)
9365 && FLOAT_TYPE_P (gnu_in_basetype)
9366 && !truncatep)
9368 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
9369 tree gnu_conv, gnu_zero, gnu_comp, calc_type;
9370 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
9371 const struct real_format *fmt;
9373 /* The following calculations depend on proper rounding to even
9374 of each arithmetic operation. In order to prevent excess
9375 precision from spoiling this property, use the widest hardware
9376 floating-point type if FP_ARITH_MAY_WIDEN is true. */
9377 calc_type
9378 = fp_arith_may_widen ? longest_float_type_node : gnu_in_basetype;
9380 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
9381 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
9382 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
9383 real_arithmetic (&pred_half, MINUS_EXPR, &dconsthalf,
9384 &half_minus_pred_half);
9385 gnu_pred_half = build_real (calc_type, pred_half);
9387 /* If the input is strictly negative, subtract this value
9388 and otherwise add it from the input. For 0.5, the result
9389 is exactly between 1.0 and the machine number preceding 1.0
9390 (for calc_type). Since the last bit of 1.0 is even, this 0.5
9391 will round to 1.0, while all other number with an absolute
9392 value less than 0.5 round to 0.0. For larger numbers exactly
9393 halfway between integers, rounding will always be correct as
9394 the true mathematical result will be closer to the higher
9395 integer compared to the lower one. So, this constant works
9396 for all floating-point numbers.
9398 The reason to use the same constant with subtract/add instead
9399 of a positive and negative constant is to allow the comparison
9400 to be scheduled in parallel with retrieval of the constant and
9401 conversion of the input to the calc_type (if necessary). */
9403 gnu_zero = build_real (gnu_in_basetype, dconst0);
9404 gnu_result = gnat_protect_expr (gnu_result);
9405 gnu_conv = convert (calc_type, gnu_result);
9406 gnu_comp
9407 = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
9408 gnu_add_pred_half
9409 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9410 gnu_subtract_pred_half
9411 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9412 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
9413 gnu_add_pred_half, gnu_subtract_pred_half);
9416 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9417 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
9418 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
9419 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
9420 else
9421 gnu_result = convert (gnu_base_type, gnu_result);
9423 /* Finally, do the range check if requested. Note that if the result type
9424 is a modular type, the range check is actually an overflow check. */
9425 if (rangep
9426 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9427 && TYPE_MODULAR_P (gnu_base_type) && overflowp))
9428 gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
9430 return convert (gnu_type, gnu_result);
9433 /* Return true if GNU_EXPR can be directly addressed. This is the case
9434 unless it is an expression involving computation or if it involves a
9435 reference to a bitfield or to an object not sufficiently aligned for
9436 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
9437 be directly addressed as an object of this type.
9439 *** Notes on addressability issues in the Ada compiler ***
9441 This predicate is necessary in order to bridge the gap between Gigi
9442 and the middle-end about addressability of GENERIC trees. A tree
9443 is said to be addressable if it can be directly addressed, i.e. if
9444 its address can be taken, is a multiple of the type's alignment on
9445 strict-alignment architectures and returns the first storage unit
9446 assigned to the object represented by the tree.
9448 In the C family of languages, everything is in practice addressable
9449 at the language level, except for bit-fields. This means that these
9450 compilers will take the address of any tree that doesn't represent
9451 a bit-field reference and expect the result to be the first storage
9452 unit assigned to the object. Even in cases where this will result
9453 in unaligned accesses at run time, nothing is supposed to be done
9454 and the program is considered as erroneous instead (see PR c/18287).
9456 The implicit assumptions made in the middle-end are in keeping with
9457 the C viewpoint described above:
9458 - the address of a bit-field reference is supposed to be never
9459 taken; the compiler (generally) will stop on such a construct,
9460 - any other tree is addressable if it is formally addressable,
9461 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
9463 In Ada, the viewpoint is the opposite one: nothing is addressable
9464 at the language level unless explicitly declared so. This means
9465 that the compiler will both make sure that the trees representing
9466 references to addressable ("aliased" in Ada parlance) objects are
9467 addressable and make no real attempts at ensuring that the trees
9468 representing references to non-addressable objects are addressable.
9470 In the first case, Ada is effectively equivalent to C and handing
9471 down the direct result of applying ADDR_EXPR to these trees to the
9472 middle-end works flawlessly. In the second case, Ada cannot afford
9473 to consider the program as erroneous if the address of trees that
9474 are not addressable is requested for technical reasons, unlike C;
9475 as a consequence, the Ada compiler must arrange for either making
9476 sure that this address is not requested in the middle-end or for
9477 compensating by inserting temporaries if it is requested in Gigi.
9479 The first goal can be achieved because the middle-end should not
9480 request the address of non-addressable trees on its own; the only
9481 exception is for the invocation of low-level block operations like
9482 memcpy, for which the addressability requirements are lower since
9483 the type's alignment can be disregarded. In practice, this means
9484 that Gigi must make sure that such operations cannot be applied to
9485 non-BLKmode bit-fields.
9487 The second goal is achieved by means of the addressable_p predicate,
9488 which computes whether a temporary must be inserted by Gigi when the
9489 address of a tree is requested; if so, the address of the temporary
9490 will be used in lieu of that of the original tree and some glue code
9491 generated to connect everything together. */
9493 static bool
9494 addressable_p (tree gnu_expr, tree gnu_type)
9496 /* For an integral type, the size of the actual type of the object may not
9497 be greater than that of the expected type, otherwise an indirect access
9498 in the latter type wouldn't correctly set all the bits of the object. */
9499 if (gnu_type
9500 && INTEGRAL_TYPE_P (gnu_type)
9501 && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
9502 return false;
9504 /* The size of the actual type of the object may not be smaller than that
9505 of the expected type, otherwise an indirect access in the latter type
9506 would be larger than the object. But only record types need to be
9507 considered in practice for this case. */
9508 if (gnu_type
9509 && TREE_CODE (gnu_type) == RECORD_TYPE
9510 && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
9511 return false;
9513 switch (TREE_CODE (gnu_expr))
9515 case VAR_DECL:
9516 case PARM_DECL:
9517 case FUNCTION_DECL:
9518 case RESULT_DECL:
9519 /* All DECLs are addressable: if they are in a register, we can force
9520 them to memory. */
9521 return true;
9523 case UNCONSTRAINED_ARRAY_REF:
9524 case INDIRECT_REF:
9525 /* Taking the address of a dereference yields the original pointer. */
9526 return true;
9528 case STRING_CST:
9529 case INTEGER_CST:
9530 /* Taking the address yields a pointer to the constant pool. */
9531 return true;
9533 case CONSTRUCTOR:
9534 /* Taking the address of a static constructor yields a pointer to the
9535 tree constant pool. */
9536 return TREE_STATIC (gnu_expr) ? true : false;
9538 case NULL_EXPR:
9539 case SAVE_EXPR:
9540 case CALL_EXPR:
9541 case PLUS_EXPR:
9542 case MINUS_EXPR:
9543 case BIT_IOR_EXPR:
9544 case BIT_XOR_EXPR:
9545 case BIT_AND_EXPR:
9546 case BIT_NOT_EXPR:
9547 /* All rvalues are deemed addressable since taking their address will
9548 force a temporary to be created by the middle-end. */
9549 return true;
9551 case COMPOUND_EXPR:
9552 /* The address of a compound expression is that of its 2nd operand. */
9553 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
9555 case COND_EXPR:
9556 /* We accept &COND_EXPR as soon as both operands are addressable and
9557 expect the outcome to be the address of the selected operand. */
9558 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
9559 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
9561 case COMPONENT_REF:
9562 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
9563 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
9564 the field is sufficiently aligned, in case it is subject
9565 to a pragma Component_Alignment. But we don't need to
9566 check the alignment of the containing record, as it is
9567 guaranteed to be not smaller than that of its most
9568 aligned field that is not a bit-field. */
9569 && (!STRICT_ALIGNMENT
9570 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
9571 >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
9572 /* The field of a padding record is always addressable. */
9573 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
9574 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9576 case ARRAY_REF: case ARRAY_RANGE_REF:
9577 case REALPART_EXPR: case IMAGPART_EXPR:
9578 case NOP_EXPR:
9579 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
9581 case CONVERT_EXPR:
9582 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
9583 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9585 case VIEW_CONVERT_EXPR:
9587 /* This is addressable if we can avoid a copy. */
9588 tree type = TREE_TYPE (gnu_expr);
9589 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
9590 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
9591 && (!STRICT_ALIGNMENT
9592 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
9593 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
9594 || ((TYPE_MODE (type) == BLKmode
9595 || TYPE_MODE (inner_type) == BLKmode)
9596 && (!STRICT_ALIGNMENT
9597 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
9598 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
9599 || TYPE_ALIGN_OK (type)
9600 || TYPE_ALIGN_OK (inner_type))))
9601 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9604 default:
9605 return false;
9609 /* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
9610 If a Freeze node exists for the entity, delay the bulk of the processing.
9611 Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
9613 void
9614 process_type (Entity_Id gnat_entity)
9616 tree gnu_old
9617 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
9619 /* If we are to delay elaboration of this type, just do any elaboration
9620 needed for expressions within the declaration and make a dummy node
9621 for it and its Full_View (if any), in case something points to it.
9622 Do not do this if it has already been done (the only way that can
9623 happen is if the private completion is also delayed). */
9624 if (Present (Freeze_Node (gnat_entity)))
9626 elaborate_entity (gnat_entity);
9628 if (!gnu_old)
9630 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
9631 save_gnu_tree (gnat_entity, gnu_decl, false);
9632 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
9633 && Present (Full_View (gnat_entity)))
9635 if (Has_Completion_In_Body (gnat_entity))
9636 DECL_TAFT_TYPE_P (gnu_decl) = 1;
9637 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
9641 return;
9644 /* If we saved away a dummy type for this node, it means that this made the
9645 type that corresponds to the full type of an incomplete type. Clear that
9646 type for now and then update the type in the pointers below. But, if the
9647 saved type is not dummy, it very likely means that we have a use before
9648 declaration for the type in the tree, what we really cannot handle. */
9649 if (gnu_old)
9651 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
9652 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
9654 save_gnu_tree (gnat_entity, NULL_TREE, false);
9657 /* Now fully elaborate the type. */
9658 tree gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, true);
9659 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
9661 /* If we have an old type and we've made pointers to this type, update those
9662 pointers. If this is a Taft amendment type in the main unit, we need to
9663 mark the type as used since other units referencing it don't see the full
9664 declaration and, therefore, cannot mark it as used themselves. */
9665 if (gnu_old)
9667 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
9668 TREE_TYPE (gnu_new));
9669 if (DECL_TAFT_TYPE_P (gnu_old))
9670 used_types_insert (TREE_TYPE (gnu_new));
9673 /* If this is a record type corresponding to a task or protected type
9674 that is a completion of an incomplete type, perform a similar update
9675 on the type. ??? Including protected types here is a guess. */
9676 if (Is_Record_Type (gnat_entity)
9677 && Is_Concurrent_Record_Type (gnat_entity)
9678 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
9680 tree gnu_task_old
9681 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
9683 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
9684 NULL_TREE, false);
9685 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
9686 gnu_new, false);
9688 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
9689 TREE_TYPE (gnu_new));
9693 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
9694 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
9695 associations that are from RECORD_TYPE. If we see an internal record, make
9696 a recursive call to fill it in as well. */
9698 static tree
9699 extract_values (tree values, tree record_type)
9701 vec<constructor_elt, va_gc> *v = NULL;
9702 tree field;
9704 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
9706 tree tem, value = NULL_TREE;
9708 /* _Parent is an internal field, but may have values in the aggregate,
9709 so check for values first. */
9710 if ((tem = purpose_member (field, values)))
9712 value = TREE_VALUE (tem);
9713 TREE_ADDRESSABLE (tem) = 1;
9716 else if (DECL_INTERNAL_P (field))
9718 value = extract_values (values, TREE_TYPE (field));
9719 if (TREE_CODE (value) == CONSTRUCTOR
9720 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value)))
9721 value = NULL_TREE;
9723 else
9724 /* If we have a record subtype, the names will match, but not the
9725 actual FIELD_DECLs. */
9726 for (tem = values; tem; tem = TREE_CHAIN (tem))
9727 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
9729 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
9730 TREE_ADDRESSABLE (tem) = 1;
9733 if (!value)
9734 continue;
9736 CONSTRUCTOR_APPEND_ELT (v, field, value);
9739 return gnat_build_constructor (record_type, v);
9742 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
9743 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
9744 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
9746 static tree
9747 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
9749 tree gnu_list = NULL_TREE, gnu_result;
9751 /* We test for GNU_FIELD being empty in the case where a variant
9752 was the last thing since we don't take things off GNAT_ASSOC in
9753 that case. We check GNAT_ASSOC in case we have a variant, but it
9754 has no fields. */
9756 for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
9758 Node_Id gnat_field = First (Choices (gnat_assoc));
9759 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
9760 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
9762 /* The expander is supposed to put a single component selector name
9763 in every record component association. */
9764 gcc_assert (No (Next (gnat_field)));
9766 /* Ignore discriminants that have Corresponding_Discriminants in tagged
9767 types since we'll be setting those fields in the parent subtype. */
9768 if (Ekind (Entity (gnat_field)) == E_Discriminant
9769 && Present (Corresponding_Discriminant (Entity (gnat_field)))
9770 && Is_Tagged_Type (Scope (Entity (gnat_field))))
9771 continue;
9773 /* Also ignore discriminants of Unchecked_Unions. */
9774 if (Ekind (Entity (gnat_field)) == E_Discriminant
9775 && Is_Unchecked_Union (gnat_entity))
9776 continue;
9778 /* Before assigning a value in an aggregate make sure range checks
9779 are done if required. Then convert to the type of the field. */
9780 if (Do_Range_Check (Expression (gnat_assoc)))
9781 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
9783 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
9785 /* Add the field and expression to the list. */
9786 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
9789 gnu_result = extract_values (gnu_list, gnu_type);
9791 if (flag_checking)
9793 /* Verify that every entry in GNU_LIST was used. */
9794 for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
9795 gcc_assert (TREE_ADDRESSABLE (gnu_list));
9798 return gnu_result;
9801 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
9802 the first element of an array aggregate. It may itself be an aggregate.
9803 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
9804 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
9805 for range checking. */
9807 static tree
9808 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
9809 Entity_Id gnat_component_type)
9811 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
9812 vec<constructor_elt, va_gc> *gnu_expr_vec = NULL;
9814 for (; Present (gnat_expr); gnat_expr = Next (gnat_expr))
9816 tree gnu_expr;
9818 /* If the expression is itself an array aggregate then first build the
9819 innermost constructor if it is part of our array (multi-dimensional
9820 case). */
9821 if (Nkind (gnat_expr) == N_Aggregate
9822 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
9823 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
9824 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
9825 TREE_TYPE (gnu_array_type),
9826 gnat_component_type);
9827 else
9829 gnu_expr = gnat_to_gnu (gnat_expr);
9831 /* Before assigning the element to the array, make sure it is
9832 in range. */
9833 if (Do_Range_Check (gnat_expr))
9834 gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
9837 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
9838 convert (TREE_TYPE (gnu_array_type), gnu_expr));
9840 gnu_index = int_const_binop (PLUS_EXPR, gnu_index,
9841 convert (TREE_TYPE (gnu_index),
9842 integer_one_node));
9845 return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
9848 /* Process a N_Validate_Unchecked_Conversion node. */
9850 static void
9851 validate_unchecked_conversion (Node_Id gnat_node)
9853 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
9854 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
9856 /* If the target is a pointer type, see if we are either converting from a
9857 non-pointer or from a pointer to a type with a different alias set and
9858 warn if so, unless the pointer has been marked to alias everything. */
9859 if (POINTER_TYPE_P (gnu_target_type)
9860 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
9862 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
9863 ? TREE_TYPE (gnu_source_type)
9864 : NULL_TREE;
9865 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
9866 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
9868 if (target_alias_set != 0
9869 && (!POINTER_TYPE_P (gnu_source_type)
9870 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
9871 target_alias_set)))
9873 post_error_ne ("?possible aliasing problem for type&",
9874 gnat_node, Target_Type (gnat_node));
9875 post_error ("\\?use -fno-strict-aliasing switch for references",
9876 gnat_node);
9877 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
9878 gnat_node, Target_Type (gnat_node));
9882 /* Likewise if the target is a fat pointer type, but we have no mechanism to
9883 mitigate the problem in this case, so we unconditionally warn. */
9884 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
9886 tree gnu_source_desig_type
9887 = TYPE_IS_FAT_POINTER_P (gnu_source_type)
9888 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
9889 : NULL_TREE;
9890 tree gnu_target_desig_type
9891 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
9892 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
9894 if (target_alias_set != 0
9895 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
9896 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
9897 target_alias_set)))
9899 post_error_ne ("?possible aliasing problem for type&",
9900 gnat_node, Target_Type (gnat_node));
9901 post_error ("\\?use -fno-strict-aliasing switch for references",
9902 gnat_node);
9907 /* EXP is to be treated as an array or record. Handle the cases when it is
9908 an access object and perform the required dereferences. */
9910 static tree
9911 maybe_implicit_deref (tree exp)
9913 /* If the type is a pointer, dereference it. */
9914 if (POINTER_TYPE_P (TREE_TYPE (exp))
9915 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
9916 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
9918 /* If we got a padded type, remove it too. */
9919 if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
9920 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
9922 return exp;
9925 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
9926 location and false if it doesn't. If CLEAR_COLUMN is true, set the column
9927 information to 0. */
9929 bool
9930 Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column)
9932 if (Sloc == No_Location)
9933 return false;
9935 if (Sloc <= Standard_Location)
9937 *locus = BUILTINS_LOCATION;
9938 return false;
9941 Source_File_Index file = Get_Source_File_Index (Sloc);
9942 Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
9943 Column_Number column = (clear_column ? 0 : Get_Column_Number (Sloc));
9944 line_map_ordinary *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
9946 /* We can have zero if pragma Source_Reference is in effect. */
9947 if (line < 1)
9948 line = 1;
9950 /* Translate the location. */
9951 *locus
9952 = linemap_position_for_line_and_column (line_table, map, line, column);
9954 return true;
9957 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
9958 don't do anything if it doesn't correspond to a source location. And,
9959 if CLEAR_COLUMN is true, set the column information to 0. */
9961 static void
9962 set_expr_location_from_node (tree node, Node_Id gnat_node, bool clear_column)
9964 location_t locus;
9966 if (!Sloc_to_locus (Sloc (gnat_node), &locus, clear_column))
9967 return;
9969 SET_EXPR_LOCATION (node, locus);
9972 /* More elaborate version of set_expr_location_from_node to be used in more
9973 general contexts, for example the result of the translation of a generic
9974 GNAT node. */
9976 static void
9977 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
9979 /* Set the location information on the node if it is a real expression.
9980 References can be reused for multiple GNAT nodes and they would get
9981 the location information of their last use. Also make sure not to
9982 overwrite an existing location as it is probably more precise. */
9984 switch (TREE_CODE (node))
9986 CASE_CONVERT:
9987 case NON_LVALUE_EXPR:
9988 case SAVE_EXPR:
9989 break;
9991 case COMPOUND_EXPR:
9992 if (EXPR_P (TREE_OPERAND (node, 1)))
9993 set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
9995 /* ... fall through ... */
9997 default:
9998 if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
10000 set_expr_location_from_node (node, gnat_node);
10001 set_end_locus_from_node (node, gnat_node);
10003 break;
10007 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
10008 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
10009 most sense. Return true if a sensible assignment was performed. */
10011 static bool
10012 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
10014 Node_Id gnat_end_label;
10015 location_t end_locus;
10017 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
10018 end_locus when there is one. We consider only GNAT nodes with a possible
10019 End_Label attached. If the End_Label actually was unassigned, fallback
10020 on the original node. We'd better assign an explicit sloc associated with
10021 the outer construct in any case. */
10023 switch (Nkind (gnat_node))
10025 case N_Package_Body:
10026 case N_Subprogram_Body:
10027 case N_Block_Statement:
10028 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
10029 break;
10031 case N_Package_Declaration:
10032 gnat_end_label = End_Label (Specification (gnat_node));
10033 break;
10035 default:
10036 return false;
10039 if (Present (gnat_end_label))
10040 gnat_node = gnat_end_label;
10042 /* Some expanded subprograms have neither an End_Label nor a Sloc
10043 attached. Notify that to callers. For a block statement with no
10044 End_Label, clear column information, so that the tree for a
10045 transient block does not receive the sloc of a source condition. */
10046 if (!Sloc_to_locus (Sloc (gnat_node), &end_locus,
10047 No (gnat_end_label)
10048 && (Nkind (gnat_node) == N_Block_Statement)))
10049 return false;
10051 switch (TREE_CODE (gnu_node))
10053 case BIND_EXPR:
10054 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
10055 return true;
10057 case FUNCTION_DECL:
10058 DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
10059 return true;
10061 default:
10062 return false;
10066 /* Return a colon-separated list of encodings contained in encoded Ada
10067 name. */
10069 static const char *
10070 extract_encoding (const char *name)
10072 char *encoding = (char *) ggc_alloc_atomic (strlen (name));
10073 get_encoding (name, encoding);
10074 return encoding;
10077 /* Extract the Ada name from an encoded name. */
10079 static const char *
10080 decode_name (const char *name)
10082 char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
10083 __gnat_decode (name, decoded, 0);
10084 return decoded;
10087 /* Post an error message. MSG is the error message, properly annotated.
10088 NODE is the node at which to post the error and the node to use for the
10089 '&' substitution. */
10091 void
10092 post_error (const char *msg, Node_Id node)
10094 String_Template temp;
10095 String_Pointer sp;
10097 if (No (node))
10098 return;
10100 temp.Low_Bound = 1;
10101 temp.High_Bound = strlen (msg);
10102 sp.Bounds = &temp;
10103 sp.Array = msg;
10104 Error_Msg_N (sp, node);
10107 /* Similar to post_error, but NODE is the node at which to post the error and
10108 ENT is the node to use for the '&' substitution. */
10110 void
10111 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
10113 String_Template temp;
10114 String_Pointer sp;
10116 if (No (node))
10117 return;
10119 temp.Low_Bound = 1;
10120 temp.High_Bound = strlen (msg);
10121 sp.Bounds = &temp;
10122 sp.Array = msg;
10123 Error_Msg_NE (sp, node, ent);
10126 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
10128 void
10129 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
10131 Error_Msg_Uint_1 = UI_From_Int (num);
10132 post_error_ne (msg, node, ent);
10135 /* Similar to post_error_ne, but T is a GCC tree representing the number to
10136 write. If T represents a constant, the text inside curly brackets in
10137 MSG will be output (presumably including a '^'). Otherwise it will not
10138 be output and the text inside square brackets will be output instead. */
10140 void
10141 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
10143 char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
10144 char start_yes, end_yes, start_no, end_no;
10145 const char *p;
10146 char *q;
10148 if (TREE_CODE (t) == INTEGER_CST)
10150 Error_Msg_Uint_1 = UI_From_gnu (t);
10151 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
10153 else
10154 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
10156 for (p = msg, q = new_msg; *p; p++)
10158 if (*p == start_yes)
10159 for (p++; *p != end_yes; p++)
10160 *q++ = *p;
10161 else if (*p == start_no)
10162 for (p++; *p != end_no; p++)
10164 else
10165 *q++ = *p;
10168 *q = 0;
10170 post_error_ne (new_msg, node, ent);
10173 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
10175 void
10176 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
10177 int num)
10179 Error_Msg_Uint_2 = UI_From_Int (num);
10180 post_error_ne_tree (msg, node, ent, t);
10183 /* Return a label to branch to for the exception type in KIND or NULL_TREE
10184 if none. */
10186 tree
10187 get_exception_label (char kind)
10189 switch (kind)
10191 case N_Raise_Constraint_Error:
10192 return gnu_constraint_error_label_stack->last ();
10194 case N_Raise_Storage_Error:
10195 return gnu_storage_error_label_stack->last ();
10197 case N_Raise_Program_Error:
10198 return gnu_program_error_label_stack->last ();
10200 default:
10201 break;
10204 return NULL_TREE;
10207 /* Return the decl for the current elaboration procedure. */
10209 static tree
10210 get_elaboration_procedure (void)
10212 return gnu_elab_proc_stack->last ();
10215 /* Initialize the table that maps GNAT codes to GCC codes for simple
10216 binary and unary operations. */
10218 static void
10219 init_code_table (void)
10221 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
10222 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
10223 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
10224 gnu_codes[N_Op_Eq] = EQ_EXPR;
10225 gnu_codes[N_Op_Ne] = NE_EXPR;
10226 gnu_codes[N_Op_Lt] = LT_EXPR;
10227 gnu_codes[N_Op_Le] = LE_EXPR;
10228 gnu_codes[N_Op_Gt] = GT_EXPR;
10229 gnu_codes[N_Op_Ge] = GE_EXPR;
10230 gnu_codes[N_Op_Add] = PLUS_EXPR;
10231 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
10232 gnu_codes[N_Op_Multiply] = MULT_EXPR;
10233 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
10234 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
10235 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
10236 gnu_codes[N_Op_Abs] = ABS_EXPR;
10237 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
10238 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
10239 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
10240 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
10241 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
10242 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
10243 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
10244 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
10247 #include "gt-ada-trans.h"